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             {
 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
3386             || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3387             || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3388         {
3389             SvGROW(TARG, 2);
3390             tmps = SvPVX(TARG);
3391             SvCUR_set(TARG, 1);
3392             *tmps++ = (char)value;
3393             *tmps = '\0';
3394             SvUTF8_off(TARG);
3395         }
3396     }
3397
3398     XPUSHs(TARG);
3399     RETURN;
3400 }
3401
3402 PP(pp_crypt)
3403 {
3404 #ifdef HAS_CRYPT
3405     dVAR; dSP; dTARGET;
3406     dPOPTOPssrl;
3407     STRLEN len;
3408     const char *tmps = SvPV_const(left, len);
3409
3410     if (DO_UTF8(left)) {
3411          /* If Unicode, try to downgrade.
3412           * If not possible, croak.
3413           * Yes, we made this up.  */
3414          SV* const tsv = sv_2mortal(newSVsv(left));
3415
3416          SvUTF8_on(tsv);
3417          sv_utf8_downgrade(tsv, FALSE);
3418          tmps = SvPV_const(tsv, len);
3419     }
3420 #   ifdef USE_ITHREADS
3421 #     ifdef HAS_CRYPT_R
3422     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3423       /* This should be threadsafe because in ithreads there is only
3424        * one thread per interpreter.  If this would not be true,
3425        * we would need a mutex to protect this malloc. */
3426         PL_reentrant_buffer->_crypt_struct_buffer =
3427           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3428 #if defined(__GLIBC__) || defined(__EMX__)
3429         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3430             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3431             /* work around glibc-2.2.5 bug */
3432             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3433         }
3434 #endif
3435     }
3436 #     endif /* HAS_CRYPT_R */
3437 #   endif /* USE_ITHREADS */
3438 #   ifdef FCRYPT
3439     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3440 #   else
3441     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3442 #   endif
3443     SETTARG;
3444     RETURN;
3445 #else
3446     DIE(aTHX_
3447       "The crypt() function is unimplemented due to excessive paranoia.");
3448 #endif
3449 }
3450
3451 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3452  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3453
3454 /* Generates code to store a unicode codepoint c that is known to occupy
3455  * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
3456  * and p is advanced to point to the next available byte after the two bytes */
3457 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c)                                      \
3458     STMT_START {                                                            \
3459         *(p)++ = UTF8_TWO_BYTE_HI(c);                                       \
3460         *((p)++) = UTF8_TWO_BYTE_LO(c);                                     \
3461     } STMT_END
3462
3463 PP(pp_ucfirst)
3464 {
3465     /* Actually is both lcfirst() and ucfirst().  Only the first character
3466      * changes.  This means that possibly we can change in-place, ie., just
3467      * take the source and change that one character and store it back, but not
3468      * if read-only etc, or if the length changes */
3469
3470     dVAR;
3471     dSP;
3472     SV *source = TOPs;
3473     STRLEN slen; /* slen is the byte length of the whole SV. */
3474     STRLEN need;
3475     SV *dest;
3476     bool inplace;   /* ? Convert first char only, in-place */
3477     bool doing_utf8 = FALSE;               /* ? using utf8 */
3478     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3479     const int op_type = PL_op->op_type;
3480     const U8 *s;
3481     U8 *d;
3482     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3483     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3484                      * stored as UTF-8 at s. */
3485     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3486                      * lowercased) character stored in tmpbuf.  May be either
3487                      * UTF-8 or not, but in either case is the number of bytes */
3488     bool tainted = FALSE;
3489
3490     SvGETMAGIC(source);
3491     if (SvOK(source)) {
3492         s = (const U8*)SvPV_nomg_const(source, slen);
3493     } else {
3494         if (ckWARN(WARN_UNINITIALIZED))
3495             report_uninit(source);
3496         s = (const U8*)"";
3497         slen = 0;
3498     }
3499
3500     /* We may be able to get away with changing only the first character, in
3501      * place, but not if read-only, etc.  Later we may discover more reasons to
3502      * not convert in-place. */
3503     inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3504
3505     /* First calculate what the changed first character should be.  This affects
3506      * whether we can just swap it out, leaving the rest of the string unchanged,
3507      * or even if have to convert the dest to UTF-8 when the source isn't */
3508
3509     if (! slen) {   /* If empty */
3510         need = 1; /* still need a trailing NUL */
3511         ulen = 0;
3512     }
3513     else if (DO_UTF8(source)) { /* Is the source utf8? */
3514         doing_utf8 = TRUE;
3515         ulen = UTF8SKIP(s);
3516         if (op_type == OP_UCFIRST) {
3517             _to_utf8_title_flags(s, tmpbuf, &tculen,
3518                                  cBOOL(IN_LOCALE_RUNTIME), &tainted);
3519         }
3520         else {
3521             _to_utf8_lower_flags(s, tmpbuf, &tculen,
3522                                  cBOOL(IN_LOCALE_RUNTIME), &tainted);
3523         }
3524
3525         /* we can't do in-place if the length changes.  */
3526         if (ulen != tculen) inplace = FALSE;
3527         need = slen + 1 - ulen + tculen;
3528     }
3529     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3530             * latin1 is treated as caseless.  Note that a locale takes
3531             * precedence */
3532         ulen = 1;       /* Original character is 1 byte */
3533         tculen = 1;     /* Most characters will require one byte, but this will
3534                          * need to be overridden for the tricky ones */
3535         need = slen + 1;
3536
3537         if (op_type == OP_LCFIRST) {
3538
3539             /* lower case the first letter: no trickiness for any character */
3540             *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3541                         ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3542         }
3543         /* is ucfirst() */
3544         else if (IN_LOCALE_RUNTIME) {
3545             *tmpbuf = toUPPER_LC(*s);   /* This would be a bug if any locales
3546                                          * have upper and title case different
3547                                          */
3548         }
3549         else if (! IN_UNI_8_BIT) {
3550             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3551                                          * on EBCDIC machines whatever the
3552                                          * native function does */
3553         }
3554         else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3555             UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3556             if (tculen > 1) {
3557                 assert(tculen == 2);
3558
3559                 /* If the result is an upper Latin1-range character, it can
3560                  * still be represented in one byte, which is its ordinal */
3561                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3562                     *tmpbuf = (U8) title_ord;
3563                     tculen = 1;
3564                 }
3565                 else {
3566                     /* Otherwise it became more than one ASCII character (in
3567                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3568                      * beyond Latin1, so the number of bytes changed, so can't
3569                      * replace just the first character in place. */
3570                     inplace = FALSE;
3571
3572                     /* If the result won't fit in a byte, the entire result will
3573                      * have to be in UTF-8.  Assume worst case sizing in
3574                      * conversion. (all latin1 characters occupy at most two bytes
3575                      * in utf8) */
3576                     if (title_ord > 255) {
3577                         doing_utf8 = TRUE;
3578                         convert_source_to_utf8 = TRUE;
3579                         need = slen * 2 + 1;
3580
3581                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3582                          * (both) characters whose title case is above 255 is
3583                          * 2. */
3584                         ulen = 2;
3585                     }
3586                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3587                         need = slen + 1 + 1;
3588                     }
3589                 }
3590             }
3591         } /* End of use Unicode (Latin1) semantics */
3592     } /* End of changing the case of the first character */
3593
3594     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3595      * generate the result */
3596     if (inplace) {
3597
3598         /* We can convert in place.  This means we change just the first
3599          * character without disturbing the rest; no need to grow */
3600         dest = source;
3601         s = d = (U8*)SvPV_force_nomg(source, slen);
3602     } else {
3603         dTARGET;
3604
3605         dest = TARG;
3606
3607         /* Here, we can't convert in place; we earlier calculated how much
3608          * space we will need, so grow to accommodate that */
3609         SvUPGRADE(dest, SVt_PV);
3610         d = (U8*)SvGROW(dest, need);
3611         (void)SvPOK_only(dest);
3612
3613         SETs(dest);
3614     }
3615
3616     if (doing_utf8) {
3617         if (! inplace) {
3618             if (! convert_source_to_utf8) {
3619
3620                 /* Here  both source and dest are in UTF-8, but have to create
3621                  * the entire output.  We initialize the result to be the
3622                  * title/lower cased first character, and then append the rest
3623                  * of the string. */
3624                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3625                 if (slen > ulen) {
3626                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3627                 }
3628             }
3629             else {
3630                 const U8 *const send = s + slen;
3631
3632                 /* Here the dest needs to be in UTF-8, but the source isn't,
3633                  * except we earlier UTF-8'd the first character of the source
3634                  * into tmpbuf.  First put that into dest, and then append the
3635                  * rest of the source, converting it to UTF-8 as we go. */
3636
3637                 /* Assert tculen is 2 here because the only two characters that
3638                  * get to this part of the code have 2-byte UTF-8 equivalents */
3639                 *d++ = *tmpbuf;
3640                 *d++ = *(tmpbuf + 1);
3641                 s++;    /* We have just processed the 1st char */
3642
3643                 for (; s < send; s++) {
3644                     d = uvchr_to_utf8(d, *s);
3645                 }
3646                 *d = '\0';
3647                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3648             }
3649             SvUTF8_on(dest);
3650         }
3651         else {   /* in-place UTF-8.  Just overwrite the first character */
3652             Copy(tmpbuf, d, tculen, U8);
3653             SvCUR_set(dest, need - 1);
3654         }
3655
3656         if (tainted) {
3657             TAINT;
3658             SvTAINTED_on(dest);
3659         }
3660     }
3661     else {  /* Neither source nor dest are in or need to be UTF-8 */
3662         if (slen) {
3663             if (IN_LOCALE_RUNTIME) {
3664                 TAINT;
3665                 SvTAINTED_on(dest);
3666             }
3667             if (inplace) {  /* in-place, only need to change the 1st char */
3668                 *d = *tmpbuf;
3669             }
3670             else {      /* Not in-place */
3671
3672                 /* Copy the case-changed character(s) from tmpbuf */
3673                 Copy(tmpbuf, d, tculen, U8);
3674                 d += tculen - 1; /* Code below expects d to point to final
3675                                   * character stored */
3676             }
3677         }
3678         else {  /* empty source */
3679             /* See bug #39028: Don't taint if empty  */
3680             *d = *s;
3681         }
3682
3683         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3684          * the destination to retain that flag */
3685         if (SvUTF8(source))
3686             SvUTF8_on(dest);
3687
3688         if (!inplace) { /* Finish the rest of the string, unchanged */
3689             /* This will copy the trailing NUL  */
3690             Copy(s + 1, d + 1, slen, U8);
3691             SvCUR_set(dest, need - 1);
3692         }
3693     }
3694     if (dest != source && SvTAINTED(source))
3695         SvTAINT(dest);
3696     SvSETMAGIC(dest);
3697     RETURN;
3698 }
3699
3700 /* There's so much setup/teardown code common between uc and lc, I wonder if
3701    it would be worth merging the two, and just having a switch outside each
3702    of the three tight loops.  There is less and less commonality though */
3703 PP(pp_uc)
3704 {
3705     dVAR;
3706     dSP;
3707     SV *source = TOPs;
3708     STRLEN len;
3709     STRLEN min;
3710     SV *dest;
3711     const U8 *s;
3712     U8 *d;
3713
3714     SvGETMAGIC(source);
3715
3716     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3717         && SvTEMP(source) && !DO_UTF8(source)
3718         && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3719
3720         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3721          * make the loop tight, so we overwrite the source with the dest before
3722          * looking at it, and we need to look at the original source
3723          * afterwards.  There would also need to be code added to handle
3724          * switching to not in-place in midstream if we run into characters
3725          * that change the length.
3726          */
3727         dest = source;
3728         s = d = (U8*)SvPV_force_nomg(source, len);
3729         min = len + 1;
3730     } else {
3731         dTARGET;
3732
3733         dest = TARG;
3734
3735         /* The old implementation would copy source into TARG at this point.
3736            This had the side effect that if source was undef, TARG was now
3737            an undefined SV with PADTMP set, and they don't warn inside
3738            sv_2pv_flags(). However, we're now getting the PV direct from
3739            source, which doesn't have PADTMP set, so it would warn. Hence the
3740            little games.  */
3741
3742         if (SvOK(source)) {
3743             s = (const U8*)SvPV_nomg_const(source, len);
3744         } else {
3745             if (ckWARN(WARN_UNINITIALIZED))
3746                 report_uninit(source);
3747             s = (const U8*)"";
3748             len = 0;
3749         }
3750         min = len + 1;
3751
3752         SvUPGRADE(dest, SVt_PV);
3753         d = (U8*)SvGROW(dest, min);
3754         (void)SvPOK_only(dest);
3755
3756         SETs(dest);
3757     }
3758
3759     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3760        to check DO_UTF8 again here.  */
3761
3762     if (DO_UTF8(source)) {
3763         const U8 *const send = s + len;
3764         U8 tmpbuf[UTF8_MAXBYTES+1];
3765         bool tainted = FALSE;
3766
3767         /* All occurrences of these are to be moved to follow any other marks.
3768          * This is context-dependent.  We may not be passed enough context to
3769          * move the iota subscript beyond all of them, but we do the best we can
3770          * with what we're given.  The result is always better than if we
3771          * hadn't done this.  And, the problem would only arise if we are
3772          * passed a character without all its combining marks, which would be
3773          * the caller's mistake.  The information this is based on comes from a
3774          * comment in Unicode SpecialCasing.txt, (and the Standard's text
3775          * itself) and so can't be checked properly to see if it ever gets
3776          * revised.  But the likelihood of it changing is remote */
3777         bool in_iota_subscript = FALSE;
3778
3779         while (s < send) {
3780             STRLEN u;
3781             STRLEN ulen;
3782             UV uv;
3783             if (in_iota_subscript && ! is_utf8_mark(s)) {
3784
3785                 /* A non-mark.  Time to output the iota subscript */
3786 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3787 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3788
3789                 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3790                 in_iota_subscript = FALSE;
3791             }
3792
3793             /* Then handle the current character.  Get the changed case value
3794              * and copy it to the output buffer */
3795
3796             u = UTF8SKIP(s);
3797             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3798                                       cBOOL(IN_LOCALE_RUNTIME), &tainted);
3799             if (uv == GREEK_CAPITAL_LETTER_IOTA
3800                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3801             {
3802                 in_iota_subscript = TRUE;
3803             }
3804             else {
3805                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3806                     /* If the eventually required minimum size outgrows the
3807                      * available space, we need to grow. */
3808                     const UV o = d - (U8*)SvPVX_const(dest);
3809
3810                     /* If someone uppercases one million U+03B0s we SvGROW()
3811                      * one million times.  Or we could try guessing how much to
3812                      * allocate without allocating too much.  Such is life.
3813                      * See corresponding comment in lc code for another option
3814                      * */
3815                     SvGROW(dest, min);
3816                     d = (U8*)SvPVX(dest) + o;
3817                 }
3818                 Copy(tmpbuf, d, ulen, U8);
3819                 d += ulen;
3820             }
3821             s += u;
3822         }
3823         if (in_iota_subscript) {
3824             CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3825         }
3826         SvUTF8_on(dest);
3827         *d = '\0';
3828
3829         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3830         if (tainted) {
3831             TAINT;
3832             SvTAINTED_on(dest);
3833         }
3834     }
3835     else {      /* Not UTF-8 */
3836         if (len) {
3837             const U8 *const send = s + len;
3838
3839             /* Use locale casing if in locale; regular style if not treating
3840              * latin1 as having case; otherwise the latin1 casing.  Do the
3841              * whole thing in a tight loop, for speed, */
3842             if (IN_LOCALE_RUNTIME) {
3843                 TAINT;
3844                 SvTAINTED_on(dest);
3845                 for (; s < send; d++, s++)
3846                     *d = toUPPER_LC(*s);
3847             }
3848             else if (! IN_UNI_8_BIT) {
3849                 for (; s < send; d++, s++) {
3850                     *d = toUPPER(*s);
3851                 }
3852             }
3853             else {
3854                 for (; s < send; d++, s++) {
3855                     *d = toUPPER_LATIN1_MOD(*s);
3856                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) continue;
3857
3858                     /* The mainstream case is the tight loop above.  To avoid
3859                      * extra tests in that, all three characters that require
3860                      * special handling are mapped by the MOD to the one tested
3861                      * just above.
3862                      * Use the source to distinguish between the three cases */
3863
3864                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3865
3866                         /* uc() of this requires 2 characters, but they are
3867                          * ASCII.  If not enough room, grow the string */
3868                         if (SvLEN(dest) < ++min) {
3869                             const UV o = d - (U8*)SvPVX_const(dest);
3870                             SvGROW(dest, min);
3871                             d = (U8*)SvPVX(dest) + o;
3872                         }
3873                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3874                         continue;   /* Back to the tight loop; still in ASCII */
3875                     }
3876
3877                     /* The other two special handling characters have their
3878                      * upper cases outside the latin1 range, hence need to be
3879                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
3880                      * here we are somewhere in the middle of processing a
3881                      * non-UTF-8 string, and realize that we will have to convert
3882                      * the whole thing to UTF-8.  What to do?  There are
3883                      * several possibilities.  The simplest to code is to
3884                      * convert what we have so far, set a flag, and continue on
3885                      * in the loop.  The flag would be tested each time through
3886                      * the loop, and if set, the next character would be
3887                      * converted to UTF-8 and stored.  But, I (khw) didn't want
3888                      * to slow down the mainstream case at all for this fairly
3889                      * rare case, so I didn't want to add a test that didn't
3890                      * absolutely have to be there in the loop, besides the
3891                      * possibility that it would get too complicated for
3892                      * optimizers to deal with.  Another possibility is to just
3893                      * give up, convert the source to UTF-8, and restart the
3894                      * function that way.  Another possibility is to convert
3895                      * both what has already been processed and what is yet to
3896                      * come separately to UTF-8, then jump into the loop that
3897                      * handles UTF-8.  But the most efficient time-wise of the
3898                      * ones I could think of is what follows, and turned out to
3899                      * not require much extra code.  */
3900
3901                     /* Convert what we have so far into UTF-8, telling the
3902                      * function that we know it should be converted, and to
3903                      * allow extra space for what we haven't processed yet.
3904                      * Assume the worst case space requirements for converting
3905                      * what we haven't processed so far: that it will require
3906                      * two bytes for each remaining source character, plus the
3907                      * NUL at the end.  This may cause the string pointer to
3908                      * move, so re-find it. */
3909
3910                     len = d - (U8*)SvPVX_const(dest);
3911                     SvCUR_set(dest, len);
3912                     len = sv_utf8_upgrade_flags_grow(dest,
3913                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3914                                                 (send -s) * 2 + 1);
3915                     d = (U8*)SvPVX(dest) + len;
3916
3917                     /* Now process the remainder of the source, converting to
3918                      * upper and UTF-8.  If a resulting byte is invariant in
3919                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
3920                      * append it to the output. */
3921                     for (; s < send; s++) {
3922                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
3923                         d += len;
3924                     }
3925
3926                     /* Here have processed the whole source; no need to continue
3927                      * with the outer loop.  Each character has been converted
3928                      * to upper case and converted to UTF-8 */
3929
3930                     break;
3931                 } /* End of processing all latin1-style chars */
3932             } /* End of processing all chars */
3933         } /* End of source is not empty */
3934
3935         if (source != dest) {
3936             *d = '\0';  /* Here d points to 1 after last char, add NUL */
3937             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3938         }
3939     } /* End of isn't utf8 */
3940     if (dest != source && SvTAINTED(source))
3941         SvTAINT(dest);
3942     SvSETMAGIC(dest);
3943     RETURN;
3944 }
3945
3946 PP(pp_lc)
3947 {
3948     dVAR;
3949     dSP;
3950     SV *source = TOPs;
3951     STRLEN len;
3952     STRLEN min;
3953     SV *dest;
3954     const U8 *s;
3955     U8 *d;
3956
3957     SvGETMAGIC(source);
3958
3959     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3960         && SvTEMP(source) && !DO_UTF8(source)) {
3961
3962         /* We can convert in place, as lowercasing anything in the latin1 range
3963          * (or else DO_UTF8 would have been on) doesn't lengthen it */
3964         dest = source;
3965         s = d = (U8*)SvPV_force_nomg(source, len);
3966         min = len + 1;
3967     } else {
3968         dTARGET;
3969
3970         dest = TARG;
3971
3972         /* The old implementation would copy source into TARG at this point.
3973            This had the side effect that if source was undef, TARG was now
3974            an undefined SV with PADTMP set, and they don't warn inside
3975            sv_2pv_flags(). However, we're now getting the PV direct from
3976            source, which doesn't have PADTMP set, so it would warn. Hence the
3977            little games.  */
3978
3979         if (SvOK(source)) {
3980             s = (const U8*)SvPV_nomg_const(source, len);
3981         } else {
3982             if (ckWARN(WARN_UNINITIALIZED))
3983                 report_uninit(source);
3984             s = (const U8*)"";
3985             len = 0;
3986         }
3987         min = len + 1;
3988
3989         SvUPGRADE(dest, SVt_PV);
3990         d = (U8*)SvGROW(dest, min);
3991         (void)SvPOK_only(dest);
3992
3993         SETs(dest);
3994     }
3995
3996     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3997        to check DO_UTF8 again here.  */
3998
3999     if (DO_UTF8(source)) {
4000         const U8 *const send = s + len;
4001         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4002         bool tainted = FALSE;
4003
4004         while (s < send) {
4005             const STRLEN u = UTF8SKIP(s);
4006             STRLEN ulen;
4007
4008             _to_utf8_lower_flags(s, tmpbuf, &ulen,
4009                                  cBOOL(IN_LOCALE_RUNTIME), &tainted);
4010
4011             /* Here is where we would do context-sensitive actions.  See the
4012              * commit message for this comment for why there isn't any */
4013
4014             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4015
4016                 /* If the eventually required minimum size outgrows the
4017                  * available space, we need to grow. */
4018                 const UV o = d - (U8*)SvPVX_const(dest);
4019
4020                 /* If someone lowercases one million U+0130s we SvGROW() one
4021                  * million times.  Or we could try guessing how much to
4022                  * allocate without allocating too much.  Such is life.
4023                  * Another option would be to grow an extra byte or two more
4024                  * each time we need to grow, which would cut down the million
4025                  * to 500K, with little waste */
4026                 SvGROW(dest, min);
4027                 d = (U8*)SvPVX(dest) + o;
4028             }
4029
4030             /* Copy the newly lowercased letter to the output buffer we're
4031              * building */
4032             Copy(tmpbuf, d, ulen, U8);
4033             d += ulen;
4034             s += u;
4035         }   /* End of looping through the source string */
4036         SvUTF8_on(dest);
4037         *d = '\0';
4038         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4039         if (tainted) {
4040             TAINT;
4041             SvTAINTED_on(dest);
4042         }
4043     } else {    /* Not utf8 */
4044         if (len) {
4045             const U8 *const send = s + len;
4046
4047             /* Use locale casing if in locale; regular style if not treating
4048              * latin1 as having case; otherwise the latin1 casing.  Do the
4049              * whole thing in a tight loop, for speed, */
4050             if (IN_LOCALE_RUNTIME) {
4051                 TAINT;
4052                 SvTAINTED_on(dest);
4053                 for (; s < send; d++, s++)
4054                     *d = toLOWER_LC(*s);
4055             }
4056             else if (! IN_UNI_8_BIT) {
4057                 for (; s < send; d++, s++) {
4058                     *d = toLOWER(*s);
4059                 }
4060             }
4061             else {
4062                 for (; s < send; d++, s++) {
4063                     *d = toLOWER_LATIN1(*s);
4064                 }
4065             }
4066         }
4067         if (source != dest) {
4068             *d = '\0';
4069             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4070         }
4071     }
4072     if (dest != source && SvTAINTED(source))
4073         SvTAINT(dest);
4074     SvSETMAGIC(dest);
4075     RETURN;
4076 }
4077
4078 PP(pp_quotemeta)
4079 {
4080     dVAR; dSP; dTARGET;
4081     SV * const sv = TOPs;
4082     STRLEN len;
4083     register const char *s = SvPV_const(sv,len);
4084
4085     SvUTF8_off(TARG);                           /* decontaminate */
4086     if (len) {
4087         register char *d;
4088         SvUPGRADE(TARG, SVt_PV);
4089         SvGROW(TARG, (len * 2) + 1);
4090         d = SvPVX(TARG);
4091         if (DO_UTF8(sv)) {
4092             while (len) {
4093                 STRLEN ulen = UTF8SKIP(s);
4094                 bool to_quote = FALSE;
4095
4096                 if (UTF8_IS_INVARIANT(*s)) {
4097                     if (_isQUOTEMETA(*s)) {
4098                         to_quote = TRUE;
4099                     }
4100                 }
4101                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4102
4103                     /* In locale, we quote all non-ASCII Latin1 chars.
4104                      * Otherwise use the quoting rules */
4105                     if (IN_LOCALE_RUNTIME
4106                         || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
4107                     {
4108                         to_quote = TRUE;
4109                     }
4110                 }
4111                 else if (_is_utf8_quotemeta((U8 *) s)) {
4112                     to_quote = TRUE;
4113                 }
4114
4115                 if (to_quote) {
4116                     *d++ = '\\';
4117                 }
4118                 if (ulen > len)
4119                     ulen = len;
4120                 len -= ulen;
4121                 while (ulen--)
4122                     *d++ = *s++;
4123             }
4124             SvUTF8_on(TARG);
4125         }
4126         else if (IN_UNI_8_BIT) {
4127             while (len--) {
4128                 if (_isQUOTEMETA(*s))
4129                     *d++ = '\\';
4130                 *d++ = *s++;
4131             }
4132         }
4133         else {
4134             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4135              * including everything above ASCII */
4136             while (len--) {
4137                 if (!isWORDCHAR_A(*s))
4138                     *d++ = '\\';
4139                 *d++ = *s++;
4140             }
4141         }
4142         *d = '\0';
4143         SvCUR_set(TARG, d - SvPVX_const(TARG));
4144         (void)SvPOK_only_UTF8(TARG);
4145     }
4146     else
4147         sv_setpvn(TARG, s, len);
4148     SETTARG;
4149     RETURN;
4150 }
4151
4152 PP(pp_fc)
4153 {
4154     dVAR;
4155     dTARGET;
4156     dSP;
4157     SV *source = TOPs;
4158     STRLEN len;
4159     STRLEN min;
4160     SV *dest;
4161     const U8 *s;
4162     const U8 *send;
4163     U8 *d;
4164     U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1];
4165     const bool full_folding = TRUE;
4166     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4167                    | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4168
4169     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4170      * You are welcome(?) -Hugmeir
4171      */
4172
4173     SvGETMAGIC(source);
4174
4175     dest = TARG;
4176
4177     if (SvOK(source)) {
4178         s = (const U8*)SvPV_nomg_const(source, len);
4179     } else {
4180         if (ckWARN(WARN_UNINITIALIZED))
4181             report_uninit(source);
4182         s = (const U8*)"";
4183         len = 0;
4184     }
4185
4186     min = len + 1;
4187
4188     SvUPGRADE(dest, SVt_PV);
4189     d = (U8*)SvGROW(dest, min);
4190     (void)SvPOK_only(dest);
4191
4192     SETs(dest);
4193
4194     send = s + len;
4195     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4196         bool tainted = FALSE;
4197         while (s < send) {
4198             const STRLEN u = UTF8SKIP(s);
4199             STRLEN ulen;
4200
4201             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4202
4203             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4204                 const UV o = d - (U8*)SvPVX_const(dest);
4205                 SvGROW(dest, min);
4206                 d = (U8*)SvPVX(dest) + o;
4207             }
4208
4209             Copy(tmpbuf, d, ulen, U8);
4210             d += ulen;
4211             s += u;
4212         }
4213         SvUTF8_on(dest);
4214         if (tainted) {
4215             TAINT;
4216             SvTAINTED_on(dest);
4217         }
4218     } /* Unflagged string */
4219     else if (len) {
4220         /* For locale, bytes, and nothing, the behavior is supposed to be the
4221          * same as lc().
4222          */
4223         if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4224             TAINT;
4225             SvTAINTED_on(dest);
4226             for (; s < send; d++, s++)
4227                 *d = toLOWER_LC(*s);
4228         }
4229         else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4230             for (; s < send; d++, s++)
4231                 *d = toLOWER(*s);
4232         }
4233         else {
4234             /* For ASCII and the Latin-1 range, there's only two troublesome folds,
4235             * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full casefolding
4236             * becomes 'ss', and \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4237             * \x{3BC} (\N{GREEK SMALL LETTER MU}) -- For the rest, the casefold is
4238             * their lowercase.
4239             */
4240             for (; s < send; d++, s++) {
4241                 if (*s == MICRO_SIGN) {
4242                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU}, which
4243                     * is outside of the latin-1 range. There's a couple of ways to
4244                     * deal with this -- khw discusses them in pp_lc/uc, so go there :)
4245                     * What we do here is upgrade what we had already casefolded,
4246                     * then enter an inner loop that appends the rest of the characters
4247                     * as UTF-8.
4248                     */
4249                     len = d - (U8*)SvPVX_const(dest);
4250                     SvCUR_set(dest, len);
4251                     len = sv_utf8_upgrade_flags_grow(dest,
4252                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4253                                                 /* The max expansion for latin1
4254                                                  * chars is 1 byte becomes 2 */
4255                                                 (send -s) * 2 + 1);
4256                     d = (U8*)SvPVX(dest) + len;
4257
4258                     CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_SMALL_LETTER_MU);
4259                     s++;
4260                     for (; s < send; s++) {
4261                         STRLEN ulen;
4262                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4263                         if UNI_IS_INVARIANT(fc) {
4264                             if ( full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4265                                 *d++ = 's';
4266                                 *d++ = 's';
4267                             }
4268                             else
4269                                 *d++ = (U8)fc;
4270                         }
4271                         else {
4272                             Copy(tmpbuf, d, ulen, U8);
4273                             d += ulen;
4274                         }
4275                     }
4276                     break;
4277                 }
4278                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4279                     /* Under full casefolding, LATIN SMALL LETTER SHARP S becomes "ss",
4280                     * which may require growing the SV.
4281                     */
4282                     if (SvLEN(dest) < ++min) {
4283                         const UV o = d - (U8*)SvPVX_const(dest);
4284                         SvGROW(dest, min);
4285                         d = (U8*)SvPVX(dest) + o;
4286                      }
4287                     *(d)++ = 's';
4288                     *d = 's';
4289                 }
4290                 else { /* If it's not one of those two, the fold is their lower case */
4291                     *d = toLOWER_LATIN1(*s);
4292                 }
4293              }
4294         }
4295     }
4296     *d = '\0';
4297     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4298
4299     if (SvTAINTED(source))
4300         SvTAINT(dest);
4301     SvSETMAGIC(dest);
4302     RETURN;
4303 }
4304
4305 /* Arrays. */
4306
4307 PP(pp_aslice)
4308 {
4309     dVAR; dSP; dMARK; dORIGMARK;
4310     register AV *const av = MUTABLE_AV(POPs);
4311     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4312
4313     if (SvTYPE(av) == SVt_PVAV) {
4314         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4315         bool can_preserve = FALSE;
4316
4317         if (localizing) {
4318             MAGIC *mg;
4319             HV *stash;
4320
4321             can_preserve = SvCANEXISTDELETE(av);
4322         }
4323
4324         if (lval && localizing) {
4325             register SV **svp;
4326             I32 max = -1;
4327             for (svp = MARK + 1; svp <= SP; svp++) {
4328                 const I32 elem = SvIV(*svp);
4329                 if (elem > max)
4330                     max = elem;
4331             }
4332             if (max > AvMAX(av))
4333                 av_extend(av, max);
4334         }
4335
4336         while (++MARK <= SP) {
4337             register SV **svp;
4338             I32 elem = SvIV(*MARK);
4339             bool preeminent = TRUE;
4340
4341             if (localizing && can_preserve) {
4342                 /* If we can determine whether the element exist,
4343                  * Try to preserve the existenceness of a tied array
4344                  * element by using EXISTS and DELETE if possible.
4345                  * Fallback to FETCH and STORE otherwise. */
4346                 preeminent = av_exists(av, elem);
4347             }
4348
4349             svp = av_fetch(av, elem, lval);
4350             if (lval) {
4351                 if (!svp || *svp == &PL_sv_undef)
4352                     DIE(aTHX_ PL_no_aelem, elem);
4353                 if (localizing) {
4354                     if (preeminent)
4355                         save_aelem(av, elem, svp);
4356                     else
4357                         SAVEADELETE(av, elem);
4358                 }
4359             }
4360             *MARK = svp ? *svp : &PL_sv_undef;
4361         }
4362     }
4363     if (GIMME != G_ARRAY) {
4364         MARK = ORIGMARK;
4365         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4366         SP = MARK;
4367     }
4368     RETURN;
4369 }
4370
4371 /* Smart dereferencing for keys, values and each */
4372 PP(pp_rkeys)
4373 {
4374     dVAR;
4375     dSP;
4376     dPOPss;
4377
4378     SvGETMAGIC(sv);
4379
4380     if (
4381          !SvROK(sv)
4382       || (sv = SvRV(sv),
4383             (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4384           || SvOBJECT(sv)
4385          )
4386     ) {
4387         DIE(aTHX_
4388            "Type of argument to %s must be unblessed hashref or arrayref",
4389             PL_op_desc[PL_op->op_type] );
4390     }
4391
4392     if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4393         DIE(aTHX_
4394            "Can't modify %s in %s",
4395             PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4396         );
4397
4398     /* Delegate to correct function for op type */
4399     PUSHs(sv);
4400     if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4401         return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4402     }
4403     else {
4404         return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4405     }
4406 }
4407
4408 PP(pp_aeach)
4409 {
4410     dVAR;
4411     dSP;
4412     AV *array = MUTABLE_AV(POPs);
4413     const I32 gimme = GIMME_V;
4414     IV *iterp = Perl_av_iter_p(aTHX_ array);
4415     const IV current = (*iterp)++;
4416
4417     if (current > av_len(array)) {
4418         *iterp = 0;
4419         if (gimme == G_SCALAR)
4420             RETPUSHUNDEF;
4421         else
4422             RETURN;
4423     }
4424
4425     EXTEND(SP, 2);
4426     mPUSHi(current);
4427     if (gimme == G_ARRAY) {
4428         SV **const element = av_fetch(array, current, 0);
4429         PUSHs(element ? *element : &PL_sv_undef);
4430     }
4431     RETURN;
4432 }
4433
4434 PP(pp_akeys)
4435 {
4436     dVAR;
4437     dSP;
4438     AV *array = MUTABLE_AV(POPs);
4439     const I32 gimme = GIMME_V;
4440
4441     *Perl_av_iter_p(aTHX_ array) = 0;
4442
4443     if (gimme == G_SCALAR) {
4444         dTARGET;
4445         PUSHi(av_len(array) + 1);
4446     }
4447     else if (gimme == G_ARRAY) {
4448         IV n = Perl_av_len(aTHX_ array);
4449         IV i;
4450
4451         EXTEND(SP, n + 1);
4452
4453         if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4454             for (i = 0;  i <= n;  i++) {
4455                 mPUSHi(i);
4456             }
4457         }
4458         else {
4459             for (i = 0;  i <= n;  i++) {
4460                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4461                 PUSHs(elem ? *elem : &PL_sv_undef);
4462             }
4463         }
4464     }
4465     RETURN;
4466 }
4467
4468 /* Associative arrays. */
4469
4470 PP(pp_each)
4471 {
4472     dVAR;
4473     dSP;
4474     HV * hash = MUTABLE_HV(POPs);
4475     HE *entry;
4476     const I32 gimme = GIMME_V;
4477
4478     PUTBACK;
4479     /* might clobber stack_sp */
4480     entry = hv_iternext(hash);
4481     SPAGAIN;
4482
4483     EXTEND(SP, 2);
4484     if (entry) {
4485         SV* const sv = hv_iterkeysv(entry);
4486         PUSHs(sv);      /* won't clobber stack_sp */
4487         if (gimme == G_ARRAY) {
4488             SV *val;
4489             PUTBACK;
4490             /* might clobber stack_sp */
4491             val = hv_iterval(hash, entry);
4492             SPAGAIN;
4493             PUSHs(val);
4494         }
4495     }
4496     else if (gimme == G_SCALAR)
4497         RETPUSHUNDEF;
4498
4499     RETURN;
4500 }
4501
4502 STATIC OP *
4503 S_do_delete_local(pTHX)
4504 {
4505     dVAR;
4506     dSP;
4507     const I32 gimme = GIMME_V;
4508     const MAGIC *mg;
4509     HV *stash;
4510
4511     if (PL_op->op_private & OPpSLICE) {
4512         dMARK; dORIGMARK;
4513         SV * const osv = POPs;
4514         const bool tied = SvRMAGICAL(osv)
4515                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4516         const bool can_preserve = SvCANEXISTDELETE(osv)
4517                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4518         const U32 type = SvTYPE(osv);
4519         if (type == SVt_PVHV) {                 /* hash element */
4520             HV * const hv = MUTABLE_HV(osv);
4521             while (++MARK <= SP) {
4522                 SV * const keysv = *MARK;
4523                 SV *sv = NULL;
4524                 bool preeminent = TRUE;
4525                 if (can_preserve)
4526                     preeminent = hv_exists_ent(hv, keysv, 0);
4527                 if (tied) {
4528                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4529                     if (he)
4530                         sv = HeVAL(he);
4531                     else
4532                         preeminent = FALSE;
4533                 }
4534                 else {
4535                     sv = hv_delete_ent(hv, keysv, 0, 0);
4536                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4537                 }
4538                 if (preeminent) {
4539                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4540                     if (tied) {
4541                         *MARK = sv_mortalcopy(sv);
4542                         mg_clear(sv);
4543                     } else
4544                         *MARK = sv;
4545                 }
4546                 else {
4547                     SAVEHDELETE(hv, keysv);
4548                     *MARK = &PL_sv_undef;
4549                 }
4550             }
4551         }
4552         else if (type == SVt_PVAV) {                  /* array element */
4553             if (PL_op->op_flags & OPf_SPECIAL) {
4554                 AV * const av = MUTABLE_AV(osv);
4555                 while (++MARK <= SP) {
4556                     I32 idx = SvIV(*MARK);
4557                     SV *sv = NULL;
4558                     bool preeminent = TRUE;
4559                     if (can_preserve)
4560                         preeminent = av_exists(av, idx);
4561                     if (tied) {
4562                         SV **svp = av_fetch(av, idx, 1);
4563                         if (svp)
4564                             sv = *svp;
4565                         else
4566                             preeminent = FALSE;
4567                     }
4568                     else {
4569                         sv = av_delete(av, idx, 0);
4570                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4571                     }
4572                     if (preeminent) {
4573                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4574                         if (tied) {
4575                             *MARK = sv_mortalcopy(sv);
4576                             mg_clear(sv);
4577                         } else
4578                             *MARK = sv;
4579                     }
4580                     else {
4581                         SAVEADELETE(av, idx);
4582                         *MARK = &PL_sv_undef;
4583                     }
4584                 }
4585             }
4586         }
4587         else
4588             DIE(aTHX_ "Not a HASH reference");
4589         if (gimme == G_VOID)
4590             SP = ORIGMARK;
4591         else if (gimme == G_SCALAR) {
4592             MARK = ORIGMARK;
4593             if (SP > MARK)
4594                 *++MARK = *SP;
4595             else
4596                 *++MARK = &PL_sv_undef;
4597             SP = MARK;
4598         }
4599     }
4600     else {
4601         SV * const keysv = POPs;
4602         SV * const osv   = POPs;
4603         const bool tied = SvRMAGICAL(osv)
4604                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4605         const bool can_preserve = SvCANEXISTDELETE(osv)
4606                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4607         const U32 type = SvTYPE(osv);
4608         SV *sv = NULL;
4609         if (type == SVt_PVHV) {
4610             HV * const hv = MUTABLE_HV(osv);
4611             bool preeminent = TRUE;
4612             if (can_preserve)
4613                 preeminent = hv_exists_ent(hv, keysv, 0);
4614             if (tied) {
4615                 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4616                 if (he)
4617                     sv = HeVAL(he);
4618                 else
4619                     preeminent = FALSE;
4620             }
4621             else {
4622                 sv = hv_delete_ent(hv, keysv, 0, 0);
4623                 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4624             }
4625             if (preeminent) {
4626                 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4627                 if (tied) {
4628                     SV *nsv = sv_mortalcopy(sv);
4629                     mg_clear(sv);
4630                     sv = nsv;
4631                 }
4632             }
4633             else
4634                 SAVEHDELETE(hv, keysv);
4635         }
4636         else if (type == SVt_PVAV) {
4637             if (PL_op->op_flags & OPf_SPECIAL) {
4638                 AV * const av = MUTABLE_AV(osv);
4639                 I32 idx = SvIV(keysv);
4640                 bool preeminent = TRUE;
4641                 if (can_preserve)
4642                     preeminent = av_exists(av, idx);
4643                 if (tied) {
4644                     SV **svp = av_fetch(av, idx, 1);
4645                     if (svp)
4646                         sv = *svp;
4647                     else
4648                         preeminent = FALSE;
4649                 }
4650                 else {
4651                     sv = av_delete(av, idx, 0);
4652                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4653                 }
4654                 if (preeminent) {
4655                     save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4656                     if (tied) {
4657                         SV *nsv = sv_mortalcopy(sv);
4658                         mg_clear(sv);
4659                         sv = nsv;
4660                     }
4661                 }
4662                 else
4663                     SAVEADELETE(av, idx);
4664             }
4665             else
4666                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4667         }
4668         else
4669             DIE(aTHX_ "Not a HASH reference");
4670         if (!sv)
4671             sv = &PL_sv_undef;
4672         if (gimme != G_VOID)
4673             PUSHs(sv);
4674     }
4675
4676     RETURN;
4677 }
4678
4679 PP(pp_delete)
4680 {
4681     dVAR;
4682     dSP;
4683     I32 gimme;
4684     I32 discard;
4685
4686     if (PL_op->op_private & OPpLVAL_INTRO)
4687         return do_delete_local();
4688
4689     gimme = GIMME_V;
4690     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4691
4692     if (PL_op->op_private & OPpSLICE) {
4693         dMARK; dORIGMARK;
4694         HV * const hv = MUTABLE_HV(POPs);
4695         const U32 hvtype = SvTYPE(hv);
4696         if (hvtype == SVt_PVHV) {                       /* hash element */
4697             while (++MARK <= SP) {
4698                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4699                 *MARK = sv ? sv : &PL_sv_undef;
4700             }
4701         }
4702         else if (hvtype == SVt_PVAV) {                  /* array element */
4703             if (PL_op->op_flags & OPf_SPECIAL) {
4704                 while (++MARK <= SP) {
4705                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4706                     *MARK = sv ? sv : &PL_sv_undef;
4707                 }
4708             }
4709         }
4710         else
4711             DIE(aTHX_ "Not a HASH reference");
4712         if (discard)
4713             SP = ORIGMARK;
4714         else if (gimme == G_SCALAR) {
4715             MARK = ORIGMARK;
4716             if (SP > MARK)
4717                 *++MARK = *SP;
4718             else
4719                 *++MARK = &PL_sv_undef;
4720             SP = MARK;
4721         }
4722     }
4723     else {
4724         SV *keysv = POPs;
4725         HV * const hv = MUTABLE_HV(POPs);
4726         SV *sv = NULL;
4727         if (SvTYPE(hv) == SVt_PVHV)
4728             sv = hv_delete_ent(hv, keysv, discard, 0);
4729         else if (SvTYPE(hv) == SVt_PVAV) {
4730             if (PL_op->op_flags & OPf_SPECIAL)
4731                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4732             else
4733                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4734         }
4735         else
4736             DIE(aTHX_ "Not a HASH reference");
4737         if (!sv)
4738             sv = &PL_sv_undef;
4739         if (!discard)
4740             PUSHs(sv);
4741     }
4742     RETURN;
4743 }
4744
4745 PP(pp_exists)
4746 {
4747     dVAR;
4748     dSP;
4749     SV *tmpsv;
4750     HV *hv;
4751
4752     if (PL_op->op_private & OPpEXISTS_SUB) {
4753         GV *gv;
4754         SV * const sv = POPs;
4755         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4756         if (cv)
4757             RETPUSHYES;
4758         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4759             RETPUSHYES;
4760         RETPUSHNO;
4761     }
4762     tmpsv = POPs;
4763     hv = MUTABLE_HV(POPs);
4764     if (SvTYPE(hv) == SVt_PVHV) {
4765         if (hv_exists_ent(hv, tmpsv, 0))
4766             RETPUSHYES;
4767     }
4768     else if (SvTYPE(hv) == SVt_PVAV) {
4769         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4770             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4771                 RETPUSHYES;
4772         }
4773     }
4774     else {
4775         DIE(aTHX_ "Not a HASH reference");
4776     }
4777     RETPUSHNO;
4778 }
4779
4780 PP(pp_hslice)
4781 {
4782     dVAR; dSP; dMARK; dORIGMARK;
4783     register HV * const hv = MUTABLE_HV(POPs);
4784     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4785     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4786     bool can_preserve = FALSE;
4787
4788     if (localizing) {
4789         MAGIC *mg;
4790         HV *stash;
4791
4792         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4793             can_preserve = TRUE;
4794     }
4795
4796     while (++MARK <= SP) {
4797         SV * const keysv = *MARK;
4798         SV **svp;
4799         HE *he;
4800         bool preeminent = TRUE;
4801
4802         if (localizing && can_preserve) {
4803             /* If we can determine whether the element exist,
4804              * try to preserve the existenceness of a tied hash
4805              * element by using EXISTS and DELETE if possible.
4806              * Fallback to FETCH and STORE otherwise. */
4807             preeminent = hv_exists_ent(hv, keysv, 0);
4808         }
4809
4810         he = hv_fetch_ent(hv, keysv, lval, 0);
4811         svp = he ? &HeVAL(he) : NULL;
4812
4813         if (lval) {
4814             if (!svp || !*svp || *svp == &PL_sv_undef) {
4815                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4816             }
4817             if (localizing) {
4818                 if (HvNAME_get(hv) && isGV(*svp))
4819                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4820                 else if (preeminent)
4821                     save_helem_flags(hv, keysv, svp,
4822                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4823                 else
4824                     SAVEHDELETE(hv, keysv);
4825             }
4826         }
4827         *MARK = svp && *svp ? *svp : &PL_sv_undef;
4828     }
4829     if (GIMME != G_ARRAY) {
4830         MARK = ORIGMARK;
4831         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4832         SP = MARK;
4833     }
4834     RETURN;
4835 }
4836
4837 /* List operators. */
4838
4839 PP(pp_list)
4840 {
4841     dVAR; dSP; dMARK;
4842     if (GIMME != G_ARRAY) {
4843         if (++MARK <= SP)
4844             *MARK = *SP;                /* unwanted list, return last item */
4845         else
4846             *MARK = &PL_sv_undef;
4847         SP = MARK;
4848     }
4849     RETURN;
4850 }
4851
4852 PP(pp_lslice)
4853 {
4854     dVAR;
4855     dSP;
4856     SV ** const lastrelem = PL_stack_sp;
4857     SV ** const lastlelem = PL_stack_base + POPMARK;
4858     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4859     register SV ** const firstrelem = lastlelem + 1;
4860     I32 is_something_there = FALSE;
4861
4862     register const I32 max = lastrelem - lastlelem;
4863     register SV **lelem;
4864
4865     if (GIMME != G_ARRAY) {
4866         I32 ix = SvIV(*lastlelem);
4867         if (ix < 0)
4868             ix += max;
4869         if (ix < 0 || ix >= max)
4870             *firstlelem = &PL_sv_undef;
4871         else
4872             *firstlelem = firstrelem[ix];
4873         SP = firstlelem;
4874         RETURN;
4875     }
4876
4877     if (max == 0) {
4878         SP = firstlelem - 1;
4879         RETURN;
4880     }
4881
4882     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4883         I32 ix = SvIV(*lelem);
4884         if (ix < 0)
4885             ix += max;
4886         if (ix < 0 || ix >= max)
4887             *lelem = &PL_sv_undef;
4888         else {
4889             is_something_there = TRUE;
4890             if (!(*lelem = firstrelem[ix]))
4891                 *lelem = &PL_sv_undef;
4892         }
4893     }
4894     if (is_something_there)
4895         SP = lastlelem;
4896     else
4897         SP = firstlelem - 1;
4898     RETURN;
4899 }
4900
4901 PP(pp_anonlist)
4902 {
4903     dVAR; dSP; dMARK; dORIGMARK;
4904     const I32 items = SP - MARK;
4905     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4906     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4907     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4908             ? newRV_noinc(av) : av);
4909     RETURN;
4910 }
4911
4912 PP(pp_anonhash)
4913 {
4914     dVAR; dSP; dMARK; dORIGMARK;
4915     HV* const hv = newHV();
4916
4917     while (MARK < SP) {
4918         SV * const key = *++MARK;
4919         SV * const val = newSV(0);
4920         if (MARK < SP)
4921             sv_setsv(val, *++MARK);
4922         else
4923             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4924         (void)hv_store_ent(hv,key,val,0);
4925     }
4926     SP = ORIGMARK;
4927     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4928             ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4929     RETURN;
4930 }
4931
4932 static AV *
4933 S_deref_plain_array(pTHX_ AV *ary)
4934 {
4935     if (SvTYPE(ary) == SVt_PVAV) return ary;
4936     SvGETMAGIC((SV *)ary);
4937     if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4938         Perl_die(aTHX_ "Not an ARRAY reference");
4939     else if (SvOBJECT(SvRV(ary)))
4940         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4941     return (AV *)SvRV(ary);
4942 }
4943
4944 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4945 # define DEREF_PLAIN_ARRAY(ary)       \
4946    ({                                  \
4947      AV *aRrRay = ary;                  \
4948      SvTYPE(aRrRay) == SVt_PVAV          \
4949       ? aRrRay                            \
4950       : S_deref_plain_array(aTHX_ aRrRay); \
4951    })
4952 #else
4953 # define DEREF_PLAIN_ARRAY(ary)            \
4954    (                                        \
4955      PL_Sv = (SV *)(ary),                    \
4956      SvTYPE(PL_Sv) == SVt_PVAV                \
4957       ? (AV *)PL_Sv                            \
4958       : S_deref_plain_array(aTHX_ (AV *)PL_Sv)  \
4959    )
4960 #endif
4961
4962 PP(pp_splice)
4963 {
4964     dVAR; dSP; dMARK; dORIGMARK;
4965     int num_args = (SP - MARK);
4966     register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4967     register SV **src;
4968     register SV **dst;
4969     register I32 i;
4970     register I32 offset;
4971     register I32 length;
4972     I32 newlen;
4973     I32 after;
4974     I32 diff;
4975     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4976
4977     if (mg) {
4978         return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4979                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4980                                     sp - mark);
4981     }
4982
4983     SP++;
4984
4985     if (++MARK < SP) {
4986         offset = i = SvIV(*MARK);
4987         if (offset < 0)
4988             offset += AvFILLp(ary) + 1;
4989         if (offset < 0)
4990             DIE(aTHX_ PL_no_aelem, i);
4991         if (++MARK < SP) {
4992             length = SvIVx(*MARK++);
4993             if (length < 0) {
4994                 length += AvFILLp(ary) - offset + 1;
4995                 if (length < 0)
4996                     length = 0;
4997             }
4998         }
4999         else
5000             length = AvMAX(ary) + 1;            /* close enough to infinity */
5001     }
5002     else {
5003         offset = 0;
5004         length = AvMAX(ary) + 1;
5005     }
5006     if (offset > AvFILLp(ary) + 1) {
5007         if (num_args > 2)
5008             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5009         offset = AvFILLp(ary) + 1;
5010     }
5011     after = AvFILLp(ary) + 1 - (offset + length);
5012     if (after < 0) {                            /* not that much array */
5013         length += after;                        /* offset+length now in array */
5014         after = 0;
5015         if (!AvALLOC(ary))
5016             av_extend(ary, 0);
5017     }
5018
5019     /* At this point, MARK .. SP-1 is our new LIST */
5020
5021     newlen = SP - MARK;
5022     diff = newlen - length;
5023     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5024         av_reify(ary);
5025
5026     /* make new elements SVs now: avoid problems if they're from the array */
5027     for (dst = MARK, i = newlen; i; i--) {
5028         SV * const h = *dst;
5029         *dst++ = newSVsv(h);
5030     }
5031
5032     if (diff < 0) {                             /* shrinking the area */
5033         SV **tmparyval = NULL;
5034         if (newlen) {
5035             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5036             Copy(MARK, tmparyval, newlen, SV*);
5037         }
5038
5039         MARK = ORIGMARK + 1;
5040         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5041             MEXTEND(MARK, length);
5042             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5043             if (AvREAL(ary)) {
5044                 EXTEND_MORTAL(length);
5045                 for (i = length, dst = MARK; i; i--) {
5046                     sv_2mortal(*dst);   /* free them eventually */
5047                     dst++;
5048                 }
5049             }
5050             MARK += length - 1;
5051         }
5052         else {
5053             *MARK = AvARRAY(ary)[offset+length-1];
5054             if (AvREAL(ary)) {
5055                 sv_2mortal(*MARK);
5056                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5057                     SvREFCNT_dec(*dst++);       /* free them now */
5058             }
5059         }
5060         AvFILLp(ary) += diff;
5061
5062         /* pull up or down? */
5063
5064         if (offset < after) {                   /* easier to pull up */
5065             if (offset) {                       /* esp. if nothing to pull */
5066                 src = &AvARRAY(ary)[offset-1];
5067                 dst = src - diff;               /* diff is negative */
5068                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5069                     *dst-- = *src--;
5070             }
5071             dst = AvARRAY(ary);
5072             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5073             AvMAX(ary) += diff;
5074         }
5075         else {
5076             if (after) {                        /* anything to pull down? */
5077                 src = AvARRAY(ary) + offset + length;
5078                 dst = src + diff;               /* diff is negative */
5079                 Move(src, dst, after, SV*);
5080             }
5081             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5082                                                 /* avoid later double free */
5083         }
5084         i = -diff;
5085         while (i)
5086             dst[--i] = &PL_sv_undef;
5087
5088         if (newlen) {
5089             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5090             Safefree(tmparyval);
5091         }
5092     }
5093     else {                                      /* no, expanding (or same) */
5094         SV** tmparyval = NULL;
5095         if (length) {
5096             Newx(tmparyval, length, SV*);       /* so remember deletion */
5097             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5098         }
5099
5100         if (diff > 0) {                         /* expanding */
5101             /* push up or down? */
5102             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5103                 if (offset) {
5104                     src = AvARRAY(ary);
5105                     dst = src - diff;
5106                     Move(src, dst, offset, SV*);
5107                 }
5108                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5109                 AvMAX(ary) += diff;
5110                 AvFILLp(ary) += diff;
5111             }
5112             else {
5113                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5114                     av_extend(ary, AvFILLp(ary) + diff);
5115                 AvFILLp(ary) += diff;
5116
5117                 if (after) {
5118                     dst = AvARRAY(ary) + AvFILLp(ary);
5119                     src = dst - diff;
5120                     for (i = after; i; i--) {
5121                         *dst-- = *src--;
5122                     }
5123                 }
5124             }
5125         }
5126
5127         if (newlen) {
5128             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5129         }
5130
5131         MARK = ORIGMARK + 1;
5132         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5133             if (length) {
5134                 Copy(tmparyval, MARK, length, SV*);
5135                 if (AvREAL(ary)) {
5136                     EXTEND_MORTAL(length);
5137                     for (i = length, dst = MARK; i; i--) {
5138                         sv_2mortal(*dst);       /* free them eventually */
5139                         dst++;
5140                     }
5141                 }
5142             }
5143             MARK += length - 1;
5144         }
5145         else if (length--) {
5146             *MARK = tmparyval[length];
5147             if (AvREAL(ary)) {
5148                 sv_2mortal(*MARK);
5149                 while (length-- > 0)
5150                     SvREFCNT_dec(tmparyval[length]);
5151             }
5152         }
5153         else
5154             *MARK = &PL_sv_undef;
5155         Safefree(tmparyval);
5156     }
5157
5158     if (SvMAGICAL(ary))
5159         mg_set(MUTABLE_SV(ary));
5160
5161     SP = MARK;
5162     RETURN;
5163 }
5164
5165 PP(pp_push)
5166 {
5167     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5168     register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5169     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5170
5171     if (mg) {
5172         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5173         PUSHMARK(MARK);
5174         PUTBACK;
5175         ENTER_with_name("call_PUSH");
5176         call_method("PUSH",G_SCALAR|G_DISCARD);
5177         LEAVE_with_name("call_PUSH");
5178         SPAGAIN;
5179     }
5180     else {
5181         PL_delaymagic = DM_DELAY;
5182         for (++MARK; MARK <= SP; MARK++) {
5183             SV * const sv = newSV(0);
5184             if (*MARK)
5185                 sv_setsv(sv, *MARK);
5186             av_store(ary, AvFILLp(ary)+1, sv);
5187         }
5188         if (PL_delaymagic & DM_ARRAY_ISA)
5189             mg_set(MUTABLE_SV(ary));
5190
5191         PL_delaymagic = 0;
5192     }
5193     SP = ORIGMARK;
5194     if (OP_GIMME(PL_op, 0) != G_VOID) {
5195         PUSHi( AvFILL(ary) + 1 );
5196     }
5197     RETURN;
5198 }
5199
5200 PP(pp_shift)
5201 {
5202     dVAR;
5203     dSP;
5204     AV * const av = PL_op->op_flags & OPf_SPECIAL
5205         ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5206     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5207     EXTEND(SP, 1);
5208     assert (sv);
5209     if (AvREAL(av))
5210         (void)sv_2mortal(sv);
5211     PUSHs(sv);
5212     RETURN;
5213 }
5214
5215 PP(pp_unshift)
5216 {
5217     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5218     register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5219     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5220
5221     if (mg) {
5222         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5223         PUSHMARK(MARK);
5224         PUTBACK;
5225         ENTER_with_name("call_UNSHIFT");
5226         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5227         LEAVE_with_name("call_UNSHIFT");
5228         SPAGAIN;
5229     }
5230     else {
5231         register I32 i = 0;
5232         av_unshift(ary, SP - MARK);
5233         while (MARK < SP) {
5234             SV * const sv = newSVsv(*++MARK);
5235             (void)av_store(ary, i++, sv);
5236         }
5237     }
5238     SP = ORIGMARK;
5239     if (OP_GIMME(PL_op, 0) != G_VOID) {
5240         PUSHi( AvFILL(ary) + 1 );
5241     }
5242     RETURN;
5243 }
5244
5245 PP(pp_reverse)
5246 {
5247     dVAR; dSP; dMARK;
5248
5249     if (GIMME == G_ARRAY) {
5250         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5251             AV *av;
5252
5253             /* See pp_sort() */
5254             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5255             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5256             av = MUTABLE_AV((*SP));
5257             /* In-place reversing only happens in void context for the array
5258              * assignment. We don't need to push anything on the stack. */
5259             SP = MARK;
5260
5261             if (SvMAGICAL(av)) {
5262                 I32 i, j;
5263                 register SV *tmp = sv_newmortal();
5264                 /* For SvCANEXISTDELETE */
5265                 HV *stash;
5266                 const MAGIC *mg;
5267                 bool can_preserve = SvCANEXISTDELETE(av);
5268
5269                 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5270                     register SV *begin, *end;
5271
5272                     if (can_preserve) {
5273                         if (!av_exists(av, i)) {
5274                             if (av_exists(av, j)) {
5275                                 register SV *sv = av_delete(av, j, 0);
5276                                 begin = *av_fetch(av, i, TRUE);
5277                                 sv_setsv_mg(begin, sv);
5278                             }
5279                             continue;
5280                         }
5281                         else if (!av_exists(av, j)) {
5282                             register SV *sv = av_delete(av, i, 0);
5283                             end = *av_fetch(av, j, TRUE);
5284                             sv_setsv_mg(end, sv);
5285                             continue;
5286                         }
5287                     }
5288
5289                     begin = *av_fetch(av, i, TRUE);
5290                     end   = *av_fetch(av, j, TRUE);
5291                     sv_setsv(tmp,      begin);
5292                     sv_setsv_mg(begin, end);
5293                     sv_setsv_mg(end,   tmp);
5294                 }
5295             }
5296             else {
5297                 SV **begin = AvARRAY(av);
5298
5299                 if (begin) {
5300                     SV **end   = begin + AvFILLp(av);
5301
5302                     while (begin < end) {
5303                         register SV * const tmp = *begin;
5304                         *begin++ = *end;
5305                         *end--   = tmp;
5306                     }
5307                 }
5308             }
5309         }
5310         else {
5311             SV **oldsp = SP;
5312             MARK++;
5313             while (MARK < SP) {
5314                 register SV * const tmp = *MARK;
5315                 *MARK++ = *SP;
5316                 *SP--   = tmp;
5317             }
5318             /* safe as long as stack cannot get extended in the above */
5319             SP = oldsp;
5320         }
5321     }
5322     else {
5323         register char *up;
5324         register char *down;
5325         register I32 tmp;
5326         dTARGET;
5327         STRLEN len;
5328
5329         SvUTF8_off(TARG);                               /* decontaminate */
5330         if (SP - MARK > 1)
5331             do_join(TARG, &PL_sv_no, MARK, SP);
5332         else {
5333             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5334             if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5335                 report_uninit(TARG);
5336         }
5337
5338         up = SvPV_force(TARG, len);
5339         if (len > 1) {
5340             if (DO_UTF8(TARG)) {        /* first reverse each character */
5341                 U8* s = (U8*)SvPVX(TARG);
5342                 const U8* send = (U8*)(s + len);
5343                 while (s < send) {
5344                     if (UTF8_IS_INVARIANT(*s)) {
5345                         s++;
5346                         continue;
5347                     }
5348                     else {
5349                         if (!utf8_to_uvchr_buf(s, send, 0))
5350                             break;
5351                         up = (char*)s;
5352                         s += UTF8SKIP(s);
5353                         down = (char*)(s - 1);
5354                         /* reverse this character */
5355                         while (down > up) {
5356                             tmp = *up;
5357                             *up++ = *down;
5358                             *down-- = (char)tmp;
5359                         }
5360                     }
5361                 }
5362                 up = SvPVX(TARG);
5363             }
5364             down = SvPVX(TARG) + len - 1;
5365             while (down > up) {
5366                 tmp = *up;
5367                 *up++ = *down;
5368                 *down-- = (char)tmp;
5369             }
5370             (void)SvPOK_only_UTF8(TARG);
5371         }
5372         SP = MARK + 1;
5373         SETTARG;
5374     }
5375     RETURN;
5376 }
5377
5378 PP(pp_split)
5379 {
5380     dVAR; dSP; dTARG;
5381     AV *ary;
5382     register IV limit = POPi;                   /* note, negative is forever */
5383     SV * const sv = POPs;
5384     STRLEN len;
5385     register const char *s = SvPV_const(sv, len);
5386     const bool do_utf8 = DO_UTF8(sv);
5387     const char *strend = s + len;
5388     register PMOP *pm;
5389     register REGEXP *rx;
5390     register SV *dstr;
5391     register const char *m;
5392     I32 iters = 0;
5393     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5394     I32 maxiters = slen + 10;
5395     I32 trailing_empty = 0;
5396     const char *orig;
5397     const I32 origlimit = limit;
5398     I32 realarray = 0;
5399     I32 base;
5400     const I32 gimme = GIMME_V;
5401     bool gimme_scalar;
5402     const I32 oldsave = PL_savestack_ix;
5403     U32 make_mortal = SVs_TEMP;
5404     bool multiline = 0;
5405     MAGIC *mg = NULL;
5406
5407 #ifdef DEBUGGING
5408     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5409 #else
5410     pm = (PMOP*)POPs;
5411 #endif
5412     if (!pm || !s)
5413         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5414     rx = PM_GETRE(pm);
5415
5416     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5417              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5418
5419     RX_MATCH_UTF8_set(rx, do_utf8);
5420
5421 #ifdef USE_ITHREADS
5422     if (pm->op_pmreplrootu.op_pmtargetoff) {
5423         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5424     }
5425 #else
5426     if (pm->op_pmreplrootu.op_pmtargetgv) {
5427         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5428     }
5429 #endif
5430     else
5431         ary = NULL;
5432     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5433         realarray = 1;
5434         PUTBACK;
5435         av_extend(ary,0);
5436         av_clear(ary);
5437         SPAGAIN;
5438         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5439             PUSHMARK(SP);
5440             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5441         }
5442         else {
5443             if (!AvREAL(ary)) {
5444                 I32 i;
5445                 AvREAL_on(ary);
5446                 AvREIFY_off(ary);
5447                 for (i = AvFILLp(ary); i >= 0; i--)
5448                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5449             }
5450             /* temporarily switch stacks */
5451             SAVESWITCHSTACK(PL_curstack, ary);
5452             make_mortal = 0;
5453         }
5454     }
5455     base = SP - PL_stack_base;
5456     orig = s;
5457     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5458         if (do_utf8) {
5459             while (*s == ' ' || is_utf8_space((U8*)s))
5460                 s += UTF8SKIP(s);
5461         }
5462         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5463             while (isSPACE_LC(*s))
5464                 s++;
5465         }
5466         else {
5467             while (isSPACE(*s))
5468                 s++;
5469         }
5470     }
5471     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5472         multiline = 1;
5473     }
5474
5475     gimme_scalar = gimme == G_SCALAR && !ary;
5476
5477     if (!limit)
5478         limit = maxiters + 2;
5479     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5480         while (--limit) {
5481             m = s;
5482             /* this one uses 'm' and is a negative test */
5483             if (do_utf8) {
5484                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5485                     const int t = UTF8SKIP(m);
5486                     /* is_utf8_space returns FALSE for malform utf8 */
5487                     if (strend - m < t)
5488                         m = strend;
5489                     else
5490                         m += t;
5491                 }
5492             }
5493             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5494                 while (m < strend && !isSPACE_LC(*m))
5495                     ++m;
5496             } else {
5497                 while (m < strend && !isSPACE(*m))
5498                     ++m;
5499             }
5500             if (m >= strend)
5501                 break;
5502
5503             if (gimme_scalar) {
5504                 iters++;
5505                 if (m-s == 0)
5506                     trailing_empty++;
5507                 else
5508                     trailing_empty = 0;
5509             } else {
5510                 dstr = newSVpvn_flags(s, m-s,
5511                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5512                 XPUSHs(dstr);
5513             }
5514
5515             /* skip the whitespace found last */
5516             if (do_utf8)
5517                 s = m + UTF8SKIP(m);
5518             else
5519                 s = m + 1;
5520
5521             /* this one uses 's' and is a positive test */
5522             if (do_utf8) {
5523                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5524                     s +=  UTF8SKIP(s);
5525             }
5526             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5527                 while (s < strend && isSPACE_LC(*s))
5528                     ++s;
5529             } else {
5530                 while (s < strend && isSPACE(*s))
5531                     ++s;
5532             }
5533         }
5534     }
5535     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5536         while (--limit) {
5537             for (m = s; m < strend && *m != '\n'; m++)
5538                 ;
5539             m++;
5540             if (m >= strend)
5541                 break;
5542
5543             if (gimme_scalar) {
5544                 iters++;
5545                 if (m-s == 0)
5546                     trailing_empty++;
5547                 else
5548                     trailing_empty = 0;
5549             } else {
5550                 dstr = newSVpvn_flags(s, m-s,
5551                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5552                 XPUSHs(dstr);
5553             }
5554             s = m;
5555         }
5556     }
5557     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5558         /*
5559           Pre-extend the stack, either the number of bytes or
5560           characters in the string or a limited amount, triggered by:
5561
5562           my ($x, $y) = split //, $str;
5563             or
5564           split //, $str, $i;
5565         */
5566         if (!gimme_scalar) {
5567             const U32 items = limit - 1;
5568             if (items < slen)
5569                 EXTEND(SP, items);
5570             else
5571                 EXTEND(SP, slen);
5572         }
5573
5574         if (do_utf8) {
5575             while (--limit) {
5576                 /* keep track of how many bytes we skip over */
5577                 m = s;
5578                 s += UTF8SKIP(s);
5579                 if (gimme_scalar) {
5580                     iters++;
5581                     if (s-m == 0)
5582                         trailing_empty++;
5583                     else
5584                         trailing_empty = 0;
5585                 } else {
5586                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5587
5588                     PUSHs(dstr);
5589                 }
5590
5591                 if (s >= strend)
5592                     break;
5593             }
5594         } else {
5595             while (--limit) {
5596                 if (gimme_scalar) {
5597                     iters++;
5598                 } else {
5599                     dstr = newSVpvn(s, 1);
5600
5601
5602                     if (make_mortal)
5603                         sv_2mortal(dstr);
5604
5605                     PUSHs(dstr);
5606                 }
5607
5608                 s++;
5609
5610                 if (s >= strend)
5611                     break;
5612             }
5613         }
5614     }
5615     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5616              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5617              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5618              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5619         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5620         SV * const csv = CALLREG_INTUIT_STRING(rx);
5621
5622         len = RX_MINLENRET(rx);
5623         if (len == 1 && !RX_UTF8(rx) && !tail) {
5624             const char c = *SvPV_nolen_const(csv);
5625             while (--limit) {
5626                 for (m = s; m < strend && *m != c; m++)
5627                     ;
5628                 if (m >= strend)
5629                     break;
5630                 if (gimme_scalar) {
5631                     iters++;
5632                     if (m-s == 0)
5633                         trailing_empty++;
5634                     else
5635                         trailing_empty = 0;
5636                 } else {
5637                     dstr = newSVpvn_flags(s, m-s,
5638                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5639                     XPUSHs(dstr);
5640                 }
5641                 /* The rx->minlen is in characters but we want to step
5642                  * s ahead by bytes. */
5643                 if (do_utf8)
5644                     s = (char*)utf8_hop((U8*)m, len);
5645                 else
5646                     s = m + len; /* Fake \n at the end */
5647             }
5648         }
5649         else {
5650             while (s < strend && --limit &&
5651               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5652                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5653             {
5654                 if (gimme_scalar) {
5655                     iters++;
5656                     if (m-s == 0)
5657                         trailing_empty++;
5658                     else
5659                         trailing_empty = 0;
5660                 } else {
5661                     dstr = newSVpvn_flags(s, m-s,
5662                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5663                     XPUSHs(dstr);
5664                 }
5665                 /* The rx->minlen is in characters but we want to step
5666                  * s ahead by bytes. */
5667                 if (do_utf8)
5668                     s = (char*)utf8_hop((U8*)m, len);
5669                 else
5670                     s = m + len; /* Fake \n at the end */
5671             }
5672         }
5673     }
5674     else {
5675         maxiters += slen * RX_NPARENS(rx);
5676         while (s < strend && --limit)
5677         {
5678             I32 rex_return;
5679             PUTBACK;
5680             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5681                                      sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0);
5682             SPAGAIN;
5683             if (rex_return == 0)
5684                 break;
5685             TAINT_IF(RX_MATCH_TAINTED(rx));
5686             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5687                 m = s;
5688                 s = orig;
5689                 orig = RX_SUBBEG(rx);
5690                 s = orig + (m - s);
5691                 strend = s + (strend - m);
5692             }
5693             m = RX_OFFS(rx)[0].start + orig;
5694
5695             if (gimme_scalar) {
5696                 iters++;
5697                 if (m-s == 0)
5698                     trailing_empty++;
5699                 else
5700                     trailing_empty = 0;
5701             } else {
5702                 dstr = newSVpvn_flags(s, m-s,
5703                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5704                 XPUSHs(dstr);
5705             }
5706             if (RX_NPARENS(rx)) {
5707                 I32 i;
5708                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5709                     s = RX_OFFS(rx)[i].start + orig;
5710                     m = RX_OFFS(rx)[i].end + orig;
5711
5712                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5713                        parens that didn't match -- they should be set to
5714                        undef, not the empty string */
5715                     if (gimme_scalar) {
5716                         iters++;
5717                         if (m-s == 0)
5718                             trailing_empty++;
5719                         else
5720                             trailing_empty = 0;
5721                     } else {
5722                         if (m >= orig && s >= orig) {
5723                             dstr = newSVpvn_flags(s, m-s,
5724                                                  (do_utf8 ? SVf_UTF8 : 0)
5725                                                   | make_mortal);
5726                         }
5727                         else
5728                             dstr = &PL_sv_undef;  /* undef, not "" */
5729                         XPUSHs(dstr);
5730                     }
5731
5732                 }
5733             }
5734             s = RX_OFFS(rx)[0].end + orig;
5735         }
5736     }
5737
5738     if (!gimme_scalar) {
5739         iters = (SP - PL_stack_base) - base;
5740     }
5741     if (iters > maxiters)
5742         DIE(aTHX_ "Split loop");
5743
5744     /* keep field after final delim? */
5745     if (s < strend || (iters && origlimit)) {
5746         if (!gimme_scalar) {
5747             const STRLEN l = strend - s;
5748             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5749             XPUSHs(dstr);
5750         }
5751         iters++;
5752     }
5753     else if (!origlimit) {
5754         if (gimme_scalar) {
5755             iters -= trailing_empty;
5756         } else {
5757             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5758                 if (TOPs && !make_mortal)
5759                     sv_2mortal(TOPs);
5760                 *SP-- = &PL_sv_undef;
5761                 iters--;
5762             }
5763         }
5764     }
5765
5766     PUTBACK;
5767     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5768     SPAGAIN;
5769     if (realarray) {
5770         if (!mg) {
5771             if (SvSMAGICAL(ary)) {
5772                 PUTBACK;
5773                 mg_set(MUTABLE_SV(ary));
5774                 SPAGAIN;
5775             }
5776             if (gimme == G_ARRAY) {
5777                 EXTEND(SP, iters);
5778                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5779                 SP += iters;
5780                 RETURN;
5781             }
5782         }
5783         else {
5784             PUTBACK;
5785             ENTER_with_name("call_PUSH");
5786             call_method("PUSH",G_SCALAR|G_DISCARD);
5787             LEAVE_with_name("call_PUSH");
5788             SPAGAIN;
5789             if (gimme == G_ARRAY) {
5790                 I32 i;
5791                 /* EXTEND should not be needed - we just popped them */
5792                 EXTEND(SP, iters);
5793                 for (i=0; i < iters; i++) {
5794                     SV **svp = av_fetch(ary, i, FALSE);
5795                     PUSHs((svp) ? *svp : &PL_sv_undef);
5796                 }
5797                 RETURN;
5798             }
5799         }
5800     }
5801     else {
5802         if (gimme == G_ARRAY)
5803             RETURN;
5804     }
5805
5806     GETTARGET;
5807     PUSHi(iters);
5808     RETURN;
5809 }
5810
5811 PP(pp_once)
5812 {
5813     dSP;
5814     SV *const sv = PAD_SVl(PL_op->op_targ);
5815
5816     if (SvPADSTALE(sv)) {
5817         /* First time. */
5818         SvPADSTALE_off(sv);
5819         RETURNOP(cLOGOP->op_other);
5820     }
5821     RETURNOP(cLOGOP->op_next);
5822 }
5823
5824 PP(pp_lock)
5825 {
5826     dVAR;
5827     dSP;
5828     dTOPss;
5829     SV *retsv = sv;
5830     SvLOCK(sv);
5831     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5832      || SvTYPE(retsv) == SVt_PVCV) {
5833         retsv = refto(retsv);
5834     }
5835     SETs(retsv);
5836     RETURN;
5837 }
5838
5839
5840 PP(unimplemented_op)
5841 {
5842     dVAR;
5843     const Optype op_type = PL_op->op_type;
5844     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5845        with out of range op numbers - it only "special" cases op_custom.
5846        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5847        if we get here for a custom op then that means that the custom op didn't
5848        have an implementation. Given that OP_NAME() looks up the custom op
5849        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5850        registers &PL_unimplemented_op as the address of their custom op.
5851        NULL doesn't generate a useful error message. "custom" does. */
5852     const char *const name = op_type >= OP_max
5853         ? "[out of range]" : PL_op_name[PL_op->op_type];
5854     if(OP_IS_SOCKET(op_type))
5855         DIE(aTHX_ PL_no_sock_func, name);
5856     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
5857 }
5858
5859 PP(pp_boolkeys)
5860 {
5861     dVAR;
5862     dSP;
5863     HV * const hv = (HV*)POPs;
5864
5865     if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
5866
5867     if (SvRMAGICAL(hv)) {
5868         MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5869         if (mg) {
5870             XPUSHs(magic_scalarpack(hv, mg));
5871             RETURN;
5872         }
5873     }
5874
5875     XPUSHs(boolSV(HvUSEDKEYS(hv) != 0));
5876     RETURN;
5877 }
5878
5879 /* For sorting out arguments passed to a &CORE:: subroutine */
5880 PP(pp_coreargs)
5881 {
5882     dSP;
5883     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5884     int defgv = PL_opargs[opnum] & OA_DEFGV, whicharg = 0;
5885     AV * const at_ = GvAV(PL_defgv);
5886     SV **svp = at_ ? AvARRAY(at_) : NULL;
5887     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5888     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5889     bool seen_question = 0;
5890     const char *err = NULL;
5891     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5892
5893     /* Count how many args there are first, to get some idea how far to
5894        extend the stack. */
5895     while (oa) {
5896         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5897         maxargs++;
5898         if (oa & OA_OPTIONAL) seen_question = 1;
5899         if (!seen_question) minargs++;
5900         oa >>= 4;
5901     }
5902
5903     if(numargs < minargs) err = "Not enough";
5904     else if(numargs > maxargs) err = "Too many";
5905     if (err)
5906         /* diag_listed_as: Too many arguments for %s */
5907         Perl_croak(aTHX_
5908           "%s arguments for %s", err,
5909            opnum ? OP_DESC(PL_op->op_next) : SvPV_nolen_const(cSVOP_sv)
5910         );
5911
5912     /* Reset the stack pointer.  Without this, we end up returning our own
5913        arguments in list context, in addition to the values we are supposed
5914        to return.  nextstate usually does this on sub entry, but we need
5915        to run the next op with the caller's hints, so we cannot have a
5916        nextstate. */
5917     SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5918
5919     if(!maxargs) RETURN;
5920
5921     /* We do this here, rather than with a separate pushmark op, as it has
5922        to come in between two things this function does (stack reset and
5923        arg pushing).  This seems the easiest way to do it. */
5924     if (pushmark) {
5925         PUTBACK;
5926         (void)Perl_pp_pushmark(aTHX);
5927     }
5928
5929     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5930     PUTBACK; /* The code below can die in various places. */
5931
5932     oa = PL_opargs[opnum] >> OASHIFT;
5933     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5934         whicharg++;
5935         switch (oa & 7) {
5936         case OA_SCALAR:
5937             if (!numargs && defgv && whicharg == minargs + 1) {
5938                 PERL_SI * const oldsi = PL_curstackinfo;
5939                 I32 const oldcxix = oldsi->si_cxix;
5940                 CV *caller;
5941                 if (oldcxix) oldsi->si_cxix--;
5942                 else PL_curstackinfo = oldsi->si_prev;
5943                 caller = find_runcv(NULL);
5944                 PL_curstackinfo = oldsi;
5945                 oldsi->si_cxix = oldcxix;
5946                 PUSHs(find_rundefsv2(
5947                     caller,cxstack[cxstack_ix].blk_oldcop->cop_seq
5948                 ));
5949             }
5950             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5951             break;
5952         case OA_LIST:
5953             while (numargs--) {
5954                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5955                 svp++;
5956             }
5957             RETURN;
5958         case OA_HVREF:
5959             if (!svp || !*svp || !SvROK(*svp)
5960              || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5961                 DIE(aTHX_
5962                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5963                  "Type of arg %d to &CORE::%s must be hash reference",
5964                   whicharg, OP_DESC(PL_op->op_next)
5965                 );
5966             PUSHs(SvRV(*svp));
5967             break;
5968         case OA_FILEREF:
5969             if (!numargs) PUSHs(NULL);
5970             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5971                 /* no magic here, as the prototype will have added an extra
5972                    refgen and we just want what was there before that */
5973                 PUSHs(SvRV(*svp));
5974             else {
5975                 const bool constr = PL_op->op_private & whicharg;
5976                 PUSHs(S_rv2gv(aTHX_
5977                     svp && *svp ? *svp : &PL_sv_undef,
5978                     constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5979                     !constr
5980                 ));
5981             }
5982             break;
5983         case OA_SCALARREF:
5984           {
5985             const bool wantscalar =
5986                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5987             if (!svp || !*svp || !SvROK(*svp)
5988                 /* We have to permit globrefs even for the \$ proto, as
5989                    *foo is indistinguishable from ${\*foo}, and the proto-
5990                    type permits the latter. */
5991              || SvTYPE(SvRV(*svp)) > (
5992                      wantscalar       ? SVt_PVLV
5993                    : opnum == OP_LOCK ? SVt_PVCV
5994                    :                    SVt_PVHV
5995                 )
5996                )
5997                 DIE(aTHX_
5998                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5999                  "Type of arg %d to &CORE::%s must be %s",
6000                   whicharg, OP_DESC(PL_op->op_next),
6001                   wantscalar
6002                     ? "scalar reference"
6003                     : opnum == OP_LOCK
6004                        ? "reference to one of [$@%&*]"
6005                        : "reference to one of [$@%*]"
6006                 );
6007             PUSHs(SvRV(*svp));
6008             break;
6009           }
6010         default:
6011             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6012         }
6013         oa = oa >> 4;
6014     }
6015
6016     RETURN;
6017 }
6018
6019 PP(pp_runcv)
6020 {
6021     dSP;
6022     CV *cv;
6023     if (PL_op->op_private & OPpOFFBYONE) {
6024         PERL_SI * const oldsi = PL_curstackinfo;
6025         I32 const oldcxix = oldsi->si_cxix;
6026         if (oldcxix) oldsi->si_cxix--;
6027         else PL_curstackinfo = oldsi->si_prev;
6028         cv = find_runcv(NULL);
6029         PL_curstackinfo = oldsi;
6030         oldsi->si_cxix = oldcxix;
6031     }
6032     else cv = find_runcv(NULL);
6033     XPUSHs(CvUNIQUE(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6034     RETURN;
6035 }
6036
6037
6038 /*
6039  * Local variables:
6040  * c-indentation-style: bsd
6041  * c-basic-offset: 4
6042  * indent-tabs-mode: t
6043  * End:
6044  *
6045  * ex: set ts=8 sts=4 sw=4 noet:
6046  */