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