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