pp.c

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