pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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 to discover,
  13  * and no knowing what you'll find around a corner.  And Elves, sir!" --Samwise
  14  */
  15
  16 /* This file contains general pp ("push/pop") functions that execute the
  17  * opcodes that make up a perl program. A typical pp function expects to
  18  * find its arguments on the stack, and usually pushes its results onto
  19  * the stack, hence the 'pp' terminology. Each OP structure contains
  20  * a pointer to the relevant pp_foo() function.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_PP_C
  25 #include "perl.h"
  26 #include "keywords.h"
  27
  28 #include "reentr.h"
  29
  30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  31    it, since pid_t is an integral type.
  32    --AD  2/20/1998
  33 */
  34 #ifdef NEED_GETPID_PROTO
  35 extern Pid_t getpid (void);
  36 #endif
  37
  38 /*
  39  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
  40  * This switches them over to IEEE.
  41  */
  42 #if defined(LIBM_LIB_VERSION)
  43     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
  44 #endif
  45
  46 /* variations on pp_null */
  47
  48 PP(pp_stub)
  49 {
  50     dVAR;
  51     dSP;
  52     if (GIMME_V == G_SCALAR)
  53         XPUSHs(&PL_sv_undef);
  54     RETURN;
  55 }
  56
  57 /* Pushy stuff. */
  58
  59 PP(pp_padav)
  60 {
  61     dVAR; dSP; dTARGET;
  62     I32 gimme;
  63     if (PL_op->op_private & OPpLVAL_INTRO)
  64         if (!(PL_op->op_private & OPpPAD_STATE))
  65             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  66     EXTEND(SP, 1);
  67     if (PL_op->op_flags & OPf_REF) {
  68         PUSHs(TARG);
  69         RETURN;
  70     } else if (LVRET) {
  71         if (GIMME == G_SCALAR)
  72             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  73         PUSHs(TARG);
  74         RETURN;
  75     }
  76     gimme = GIMME_V;
  77     if (gimme == G_ARRAY) {
  78         const I32 maxarg = AvFILL((AV*)TARG) + 1;
  79         EXTEND(SP, maxarg);
  80         if (SvMAGICAL(TARG)) {
  81             U32 i;
  82             for (i=0; i < (U32)maxarg; i++) {
  83                 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
  84                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  85             }
  86         }
  87         else {
  88             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
  89         }
  90         SP += maxarg;
  91     }
  92     else if (gimme == G_SCALAR) {
  93         SV* const sv = sv_newmortal();
  94         const I32 maxarg = AvFILL((AV*)TARG) + 1;
  95         sv_setiv(sv, maxarg);
  96         PUSHs(sv);
  97     }
  98     RETURN;
  99 }
 100
 101 PP(pp_padhv)
 102 {
 103     dVAR; dSP; dTARGET;
 104     I32 gimme;
 105
 106     XPUSHs(TARG);
 107     if (PL_op->op_private & OPpLVAL_INTRO)
 108         if (!(PL_op->op_private & OPpPAD_STATE))
 109             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 110     if (PL_op->op_flags & OPf_REF)
 111         RETURN;
 112     else if (LVRET) {
 113         if (GIMME == G_SCALAR)
 114             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 115         RETURN;
 116     }
 117     gimme = GIMME_V;
 118     if (gimme == G_ARRAY) {
 119         RETURNOP(do_kv());
 120     }
 121     else if (gimme == G_SCALAR) {
 122         SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
 123         SETs(sv);
 124     }
 125     RETURN;
 126 }
 127
 128 /* Translations. */
 129
 130 PP(pp_rv2gv)
 131 {
 132     dVAR; dSP; dTOPss;
 133
 134     if (SvROK(sv)) {
 135       wasref:
 136         tryAMAGICunDEREF(to_gv);
 137
 138         sv = SvRV(sv);
 139         if (SvTYPE(sv) == SVt_PVIO) {
 140             GV * const gv = (GV*) sv_newmortal();
 141             gv_init(gv, 0, "", 0, 0);
 142             GvIOp(gv) = (IO *)sv;
 143             SvREFCNT_inc_void_NN(sv);
 144             sv = (SV*) gv;
 145         }
 146         else if (SvTYPE(sv) != SVt_PVGV)
 147             DIE(aTHX_ "Not a GLOB reference");
 148     }
 149     else {
 150         if (SvTYPE(sv) != SVt_PVGV) {
 151             if (SvGMAGICAL(sv)) {
 152                 mg_get(sv);
 153                 if (SvROK(sv))
 154                     goto wasref;
 155             }
 156             if (!SvOK(sv) && sv != &PL_sv_undef) {
 157                 /* If this is a 'my' scalar and flag is set then vivify
 158                  * NI-S 1999/05/07
 159                  */
 160                 if (SvREADONLY(sv))
 161                     Perl_croak(aTHX_ PL_no_modify);
 162                 if (PL_op->op_private & OPpDEREF) {
 163                     GV *gv;
 164                     if (cUNOP->op_targ) {
 165                         STRLEN len;
 166                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 167                         const char * const name = SvPV(namesv, len);
 168                         gv = (GV*)newSV(0);
 169                         gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
 170                     }
 171                     else {
 172                         const char * const name = CopSTASHPV(PL_curcop);
 173                         gv = newGVgen(name);
 174                     }
 175                     if (SvTYPE(sv) < SVt_RV)
 176                         sv_upgrade(sv, SVt_RV);
 177                     else if (SvPVX_const(sv)) {
 178                         SvPV_free(sv);
 179                         SvLEN_set(sv, 0);
 180                         SvCUR_set(sv, 0);
 181                     }
 182                     SvRV_set(sv, (SV*)gv);
 183                     SvROK_on(sv);
 184                     SvSETMAGIC(sv);
 185                     goto wasref;
 186                 }
 187                 if (PL_op->op_flags & OPf_REF ||
 188                     PL_op->op_private & HINT_STRICT_REFS)
 189                     DIE(aTHX_ PL_no_usym, "a symbol");
 190                 if (ckWARN(WARN_UNINITIALIZED))
 191                     report_uninit(sv);
 192                 RETSETUNDEF;
 193             }
 194             if ((PL_op->op_flags & OPf_SPECIAL) &&
 195                 !(PL_op->op_flags & OPf_MOD))
 196             {
 197                 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
 198                 if (!temp
 199                     && (!is_gv_magical_sv(sv,0)
 200                         || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
 201                     RETSETUNDEF;
 202                 }
 203                 sv = temp;
 204             }
 205             else {
 206                 if (PL_op->op_private & HINT_STRICT_REFS)
 207                     DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
 208                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 209                     == OPpDONT_INIT_GV) {
 210                     /* We are the target of a coderef assignment.  Return
 211                        the scalar unchanged, and let pp_sasssign deal with
 212                        things.  */
 213                     RETURN;
 214                 }
 215                 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
 216             }
 217         }
 218     }
 219     if (PL_op->op_private & OPpLVAL_INTRO)
 220         save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
 221     SETs(sv);
 222     RETURN;
 223 }
 224
 225 /* Helper function for pp_rv2sv and pp_rv2av  */
 226 GV *
 227 Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type,
 228                 SV ***spp)
 229 {
 230     dVAR;
 231     GV *gv;
 232
 233     if (PL_op->op_private & HINT_STRICT_REFS) {
 234         if (SvOK(sv))
 235             Perl_die(aTHX_ PL_no_symref_sv, sv, what);
 236         else
 237             Perl_die(aTHX_ PL_no_usym, what);
 238     }
 239     if (!SvOK(sv)) {
 240         if (PL_op->op_flags & OPf_REF)
 241             Perl_die(aTHX_ PL_no_usym, what);
 242         if (ckWARN(WARN_UNINITIALIZED))
 243             report_uninit(sv);
 244         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 245             (*spp)--;
 246             return NULL;
 247         }
 248         **spp = &PL_sv_undef;
 249         return NULL;
 250     }
 251     if ((PL_op->op_flags & OPf_SPECIAL) &&
 252         !(PL_op->op_flags & OPf_MOD))
 253         {
 254             gv = gv_fetchsv(sv, 0, type);
 255             if (!gv
 256                 && (!is_gv_magical_sv(sv,0)
 257                     || !(gv = gv_fetchsv(sv, GV_ADD, type))))
 258                 {
 259                     **spp = &PL_sv_undef;
 260                     return NULL;
 261                 }
 262         }
 263     else {
 264         gv = gv_fetchsv(sv, GV_ADD, type);
 265     }
 266     return gv;
 267 }
 268
 269 PP(pp_rv2sv)
 270 {
 271     dVAR; dSP; dTOPss;
 272     GV *gv = NULL;
 273
 274     if (SvROK(sv)) {
 275       wasref:
 276         tryAMAGICunDEREF(to_sv);
 277
 278         sv = SvRV(sv);
 279         switch (SvTYPE(sv)) {
 280         case SVt_PVAV:
 281         case SVt_PVHV:
 282         case SVt_PVCV:
 283         case SVt_PVFM:
 284         case SVt_PVIO:
 285             DIE(aTHX_ "Not a SCALAR reference");
 286         default: NOOP;
 287         }
 288     }
 289     else {
 290         gv = (GV*)sv;
 291
 292         if (SvTYPE(gv) != SVt_PVGV) {
 293             if (SvGMAGICAL(sv)) {
 294                 mg_get(sv);
 295                 if (SvROK(sv))
 296                     goto wasref;
 297             }
 298             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 299             if (!gv)
 300                 RETURN;
 301         }
 302         sv = GvSVn(gv);
 303     }
 304     if (PL_op->op_flags & OPf_MOD) {
 305         if (PL_op->op_private & OPpLVAL_INTRO) {
 306             if (cUNOP->op_first->op_type == OP_NULL)
 307                 sv = save_scalar((GV*)TOPs);
 308             else if (gv)
 309                 sv = save_scalar(gv);
 310             else
 311                 Perl_croak(aTHX_ PL_no_localize_ref);
 312         }
 313         else if (PL_op->op_private & OPpDEREF)
 314             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 315     }
 316     SETs(sv);
 317     RETURN;
 318 }
 319
 320 PP(pp_av2arylen)
 321 {
 322     dVAR; dSP;
 323     AV * const av = (AV*)TOPs;
 324     SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
 325     if (!*sv) {
 326         *sv = newSV_type(SVt_PVMG);
 327         sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
 328     }
 329     SETs(*sv);
 330     RETURN;
 331 }
 332
 333 PP(pp_pos)
 334 {
 335     dVAR; dSP; dTARGET; dPOPss;
 336
 337     if (PL_op->op_flags & OPf_MOD || LVRET) {
 338         if (SvTYPE(TARG) < SVt_PVLV) {
 339             sv_upgrade(TARG, SVt_PVLV);
 340             sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
 341         }
 342
 343         LvTYPE(TARG) = '.';
 344         if (LvTARG(TARG) != sv) {
 345             if (LvTARG(TARG))
 346                 SvREFCNT_dec(LvTARG(TARG));
 347             LvTARG(TARG) = SvREFCNT_inc_simple(sv);
 348         }
 349         PUSHs(TARG);    /* no SvSETMAGIC */
 350         RETURN;
 351     }
 352     else {
 353         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 354             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
 355             if (mg && mg->mg_len >= 0) {
 356                 I32 i = mg->mg_len;
 357                 if (DO_UTF8(sv))
 358                     sv_pos_b2u(sv, &i);
 359                 PUSHi(i + CopARYBASE_get(PL_curcop));
 360                 RETURN;
 361             }
 362         }
 363         RETPUSHUNDEF;
 364     }
 365 }
 366
 367 PP(pp_rv2cv)
 368 {
 369     dVAR; dSP;
 370     GV *gv;
 371     HV *stash_unused;
 372     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 373         ? 0
 374         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
 375             ? GV_ADD|GV_NOEXPAND
 376             : GV_ADD;
 377     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 378     /* (But not in defined().) */
 379
 380     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 381     if (cv) {
 382         if (CvCLONE(cv))
 383             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 384         if ((PL_op->op_private & OPpLVAL_INTRO)) {
 385             if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
 386                 cv = GvCV(gv);
 387             if (!CvLVALUE(cv))
 388                 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
 389         }
 390     }
 391     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 392         cv = (CV*)gv;
 393     }
 394     else
 395         cv = (CV*)&PL_sv_undef;
 396     SETs((SV*)cv);
 397     RETURN;
 398 }
 399
 400 PP(pp_prototype)
 401 {
 402     dVAR; dSP;
 403     CV *cv;
 404     HV *stash;
 405     GV *gv;
 406     SV *ret = &PL_sv_undef;
 407
 408     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 409         const char * s = SvPVX_const(TOPs);
 410         if (strnEQ(s, "CORE::", 6)) {
 411             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 412             if (code < 0) {     /* Overridable. */
 413 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 414                 int i = 0, n = 0, seen_question = 0, defgv = 0;
 415                 I32 oa;
 416                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 417
 418                 if (code == -KEY_chop || code == -KEY_chomp
 419                         || code == -KEY_exec || code == -KEY_system || code == -KEY_err)
 420                     goto set;
 421                 if (code == -KEY_mkdir) {
 422                     ret = sv_2mortal(newSVpvs("_;$"));
 423                     goto set;
 424                 }
 425                 if (code == -KEY_readpipe) {
 426                     s = "CORE::backtick";
 427                 }
 428                 while (i < MAXO) {      /* The slow way. */
 429                     if (strEQ(s + 6, PL_op_name[i])
 430                         || strEQ(s + 6, PL_op_desc[i]))
 431                     {
 432                         goto found;
 433                     }
 434                     i++;
 435                 }
 436                 goto nonesuch;          /* Should not happen... */
 437               found:
 438                 defgv = PL_opargs[i] & OA_DEFGV;
 439                 oa = PL_opargs[i] >> OASHIFT;
 440                 while (oa) {
 441                     if (oa & OA_OPTIONAL && !seen_question && !defgv) {
 442                         seen_question = 1;
 443                         str[n++] = ';';
 444                     }
 445                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 446                         && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
 447                         /* But globs are already references (kinda) */
 448                         && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
 449                     ) {
 450                         str[n++] = '\\';
 451                     }
 452                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 453                     oa = oa >> 4;
 454                 }
 455                 if (defgv && str[n - 1] == '$')
 456                     str[n - 1] = '_';
 457                 str[n++] = '\0';
 458                 ret = sv_2mortal(newSVpvn(str, n - 1));
 459             }
 460             else if (code)              /* Non-Overridable */
 461                 goto set;
 462             else {                      /* None such */
 463               nonesuch:
 464                 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
 465             }
 466         }
 467     }
 468     cv = sv_2cv(TOPs, &stash, &gv, 0);
 469     if (cv && SvPOK(cv))
 470         ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
 471   set:
 472     SETs(ret);
 473     RETURN;
 474 }
 475
 476 PP(pp_anoncode)
 477 {
 478     dVAR; dSP;
 479     CV* cv = (CV*)PAD_SV(PL_op->op_targ);
 480     if (CvCLONE(cv))
 481         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 482     EXTEND(SP,1);
 483     PUSHs((SV*)cv);
 484     RETURN;
 485 }
 486
 487 PP(pp_srefgen)
 488 {
 489     dVAR; dSP;
 490     *SP = refto(*SP);
 491     RETURN;
 492 }
 493
 494 PP(pp_refgen)
 495 {
 496     dVAR; dSP; dMARK;
 497     if (GIMME != G_ARRAY) {
 498         if (++MARK <= SP)
 499             *MARK = *SP;
 500         else
 501             *MARK = &PL_sv_undef;
 502         *MARK = refto(*MARK);
 503         SP = MARK;
 504         RETURN;
 505     }
 506     EXTEND_MORTAL(SP - MARK);
 507     while (++MARK <= SP)
 508         *MARK = refto(*MARK);
 509     RETURN;
 510 }
 511
 512 STATIC SV*
 513 S_refto(pTHX_ SV *sv)
 514 {
 515     dVAR;
 516     SV* rv;
 517
 518     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 519         if (LvTARGLEN(sv))
 520             vivify_defelem(sv);
 521         if (!(sv = LvTARG(sv)))
 522             sv = &PL_sv_undef;
 523         else
 524             SvREFCNT_inc_void_NN(sv);
 525     }
 526     else if (SvTYPE(sv) == SVt_PVAV) {
 527         if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
 528             av_reify((AV*)sv);
 529         SvTEMP_off(sv);
 530         SvREFCNT_inc_void_NN(sv);
 531     }
 532     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 533         sv = newSVsv(sv);
 534     else {
 535         SvTEMP_off(sv);
 536         SvREFCNT_inc_void_NN(sv);
 537     }
 538     rv = sv_newmortal();
 539     sv_upgrade(rv, SVt_RV);
 540     SvRV_set(rv, sv);
 541     SvROK_on(rv);
 542     return rv;
 543 }
 544
 545 PP(pp_ref)
 546 {
 547     dVAR; dSP; dTARGET;
 548     const char *pv;
 549     SV * const sv = POPs;
 550
 551     if (sv)
 552         SvGETMAGIC(sv);
 553
 554     if (!sv || !SvROK(sv))
 555         RETPUSHNO;
 556
 557     pv = sv_reftype(SvRV(sv),TRUE);
 558     PUSHp(pv, strlen(pv));
 559     RETURN;
 560 }
 561
 562 PP(pp_bless)
 563 {
 564     dVAR; dSP;
 565     HV *stash;
 566
 567     if (MAXARG == 1)
 568         stash = CopSTASH(PL_curcop);
 569     else {
 570         SV * const ssv = POPs;
 571         STRLEN len;
 572         const char *ptr;
 573
 574         if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
 575             Perl_croak(aTHX_ "Attempt to bless into a reference");
 576         ptr = SvPV_const(ssv,len);
 577         if (len == 0 && ckWARN(WARN_MISC))
 578             Perl_warner(aTHX_ packWARN(WARN_MISC),
 579                    "Explicit blessing to '' (assuming package main)");
 580         stash = gv_stashpvn(ptr, len, GV_ADD);
 581     }
 582
 583     (void)sv_bless(TOPs, stash);
 584     RETURN;
 585 }
 586
 587 PP(pp_gelem)
 588 {
 589     dVAR; dSP;
 590
 591     SV *sv = POPs;
 592     const char * const elem = SvPV_nolen_const(sv);
 593     GV * const gv = (GV*)POPs;
 594     SV * tmpRef = NULL;
 595
 596     sv = NULL;
 597     if (elem) {
 598         /* elem will always be NUL terminated.  */
 599         const char * const second_letter = elem + 1;
 600         switch (*elem) {
 601         case 'A':
 602             if (strEQ(second_letter, "RRAY"))
 603                 tmpRef = (SV*)GvAV(gv);
 604             break;
 605         case 'C':
 606             if (strEQ(second_letter, "ODE"))
 607                 tmpRef = (SV*)GvCVu(gv);
 608             break;
 609         case 'F':
 610             if (strEQ(second_letter, "ILEHANDLE")) {
 611                 /* finally deprecated in 5.8.0 */
 612                 deprecate("*glob{FILEHANDLE}");
 613                 tmpRef = (SV*)GvIOp(gv);
 614             }
 615             else
 616                 if (strEQ(second_letter, "ORMAT"))
 617                     tmpRef = (SV*)GvFORM(gv);
 618             break;
 619         case 'G':
 620             if (strEQ(second_letter, "LOB"))
 621                 tmpRef = (SV*)gv;
 622             break;
 623         case 'H':
 624             if (strEQ(second_letter, "ASH"))
 625                 tmpRef = (SV*)GvHV(gv);
 626             break;
 627         case 'I':
 628             if (*second_letter == 'O' && !elem[2])
 629                 tmpRef = (SV*)GvIOp(gv);
 630             break;
 631         case 'N':
 632             if (strEQ(second_letter, "AME"))
 633                 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
 634             break;
 635         case 'P':
 636             if (strEQ(second_letter, "ACKAGE")) {
 637                 const HV * const stash = GvSTASH(gv);
 638                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 639                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 640             }
 641             break;
 642         case 'S':
 643             if (strEQ(second_letter, "CALAR"))
 644                 tmpRef = GvSVn(gv);
 645             break;
 646         }
 647     }
 648     if (tmpRef)
 649         sv = newRV(tmpRef);
 650     if (sv)
 651         sv_2mortal(sv);
 652     else
 653         sv = &PL_sv_undef;
 654     XPUSHs(sv);
 655     RETURN;
 656 }
 657
 658 /* Pattern matching */
 659
 660 PP(pp_study)
 661 {
 662     dVAR; dSP; dPOPss;
 663     register unsigned char *s;
 664     register I32 pos;
 665     register I32 ch;
 666     register I32 *sfirst;
 667     register I32 *snext;
 668     STRLEN len;
 669
 670     if (sv == PL_lastscream) {
 671         if (SvSCREAM(sv))
 672             RETPUSHYES;
 673     }
 674     s = (unsigned char*)(SvPV(sv, len));
 675     pos = len;
 676     if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
 677         /* No point in studying a zero length string, and not safe to study
 678            anything that doesn't appear to be a simple scalar (and hence might
 679            change between now and when the regexp engine runs without our set
 680            magic ever running) such as a reference to an object with overloaded
 681            stringification.  */
 682         RETPUSHNO;
 683     }
 684
 685     if (PL_lastscream) {
 686         SvSCREAM_off(PL_lastscream);
 687         SvREFCNT_dec(PL_lastscream);
 688     }
 689     PL_lastscream = SvREFCNT_inc_simple(sv);
 690
 691     s = (unsigned char*)(SvPV(sv, len));
 692     pos = len;
 693     if (pos <= 0)
 694         RETPUSHNO;
 695     if (pos > PL_maxscream) {
 696         if (PL_maxscream < 0) {
 697             PL_maxscream = pos + 80;
 698             Newx(PL_screamfirst, 256, I32);
 699             Newx(PL_screamnext, PL_maxscream, I32);
 700         }
 701         else {
 702             PL_maxscream = pos + pos / 4;
 703             Renew(PL_screamnext, PL_maxscream, I32);
 704         }
 705     }
 706
 707     sfirst = PL_screamfirst;
 708     snext = PL_screamnext;
 709
 710     if (!sfirst || !snext)
 711         DIE(aTHX_ "do_study: out of memory");
 712
 713     for (ch = 256; ch; --ch)
 714         *sfirst++ = -1;
 715     sfirst -= 256;
 716
 717     while (--pos >= 0) {
 718         register const I32 ch = s[pos];
 719         if (sfirst[ch] >= 0)
 720             snext[pos] = sfirst[ch] - pos;
 721         else
 722             snext[pos] = -pos;
 723         sfirst[ch] = pos;
 724     }
 725
 726     SvSCREAM_on(sv);
 727     /* piggyback on m//g magic */
 728     sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
 729     RETPUSHYES;
 730 }
 731
 732 PP(pp_trans)
 733 {
 734     dVAR; dSP; dTARG;
 735     SV *sv;
 736
 737     if (PL_op->op_flags & OPf_STACKED)
 738         sv = POPs;
 739     else if (PL_op->op_private & OPpTARGET_MY)
 740         sv = GETTARGET;
 741     else {
 742         sv = DEFSV;
 743         EXTEND(SP,1);
 744     }
 745     TARG = sv_newmortal();
 746     PUSHi(do_trans(sv));
 747     RETURN;
 748 }
 749
 750 /* Lvalue operators. */
 751
 752 PP(pp_schop)
 753 {
 754     dVAR; dSP; dTARGET;
 755     do_chop(TARG, TOPs);
 756     SETTARG;
 757     RETURN;
 758 }
 759
 760 PP(pp_chop)
 761 {
 762     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
 763     while (MARK < SP)
 764         do_chop(TARG, *++MARK);
 765     SP = ORIGMARK;
 766     XPUSHTARG;
 767     RETURN;
 768 }
 769
 770 PP(pp_schomp)
 771 {
 772     dVAR; dSP; dTARGET;
 773     SETi(do_chomp(TOPs));
 774     RETURN;
 775 }
 776
 777 PP(pp_chomp)
 778 {
 779     dVAR; dSP; dMARK; dTARGET;
 780     register I32 count = 0;
 781
 782     while (SP > MARK)
 783         count += do_chomp(POPs);
 784     XPUSHi(count);
 785     RETURN;
 786 }
 787
 788 PP(pp_undef)
 789 {
 790     dVAR; dSP;
 791     SV *sv;
 792
 793     if (!PL_op->op_private) {
 794         EXTEND(SP, 1);
 795         RETPUSHUNDEF;
 796     }
 797
 798     sv = POPs;
 799     if (!sv)
 800         RETPUSHUNDEF;
 801
 802     SV_CHECK_THINKFIRST_COW_DROP(sv);
 803
 804     switch (SvTYPE(sv)) {
 805     case SVt_NULL:
 806         break;
 807     case SVt_PVAV:
 808         av_undef((AV*)sv);
 809         break;
 810     case SVt_PVHV:
 811         hv_undef((HV*)sv);
 812         break;
 813     case SVt_PVCV:
 814         if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
 815             Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
 816                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
 817         /* FALLTHROUGH */
 818     case SVt_PVFM:
 819         {
 820             /* let user-undef'd sub keep its identity */
 821             GV* const gv = CvGV((CV*)sv);
 822             cv_undef((CV*)sv);
 823             CvGV((CV*)sv) = gv;
 824         }
 825         break;
 826     case SVt_PVGV:
 827         if (SvFAKE(sv))
 828             SvSetMagicSV(sv, &PL_sv_undef);
 829         else {
 830             GP *gp;
 831             gp_free((GV*)sv);
 832             Newxz(gp, 1, GP);
 833             GvGP(sv) = gp_ref(gp);
 834             GvSV(sv) = newSV(0);
 835             GvLINE(sv) = CopLINE(PL_curcop);
 836             GvEGV(sv) = (GV*)sv;
 837             GvMULTI_on(sv);
 838         }
 839         break;
 840     default:
 841         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 842             SvPV_free(sv);
 843             SvPV_set(sv, NULL);
 844             SvLEN_set(sv, 0);
 845         }
 846         SvOK_off(sv);
 847         SvSETMAGIC(sv);
 848     }
 849
 850     RETPUSHUNDEF;
 851 }
 852
 853 PP(pp_predec)
 854 {
 855     dVAR; dSP;
 856     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 857         DIE(aTHX_ PL_no_modify);
 858     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 859         && SvIVX(TOPs) != IV_MIN)
 860     {
 861         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 862         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 863     }
 864     else
 865         sv_dec(TOPs);
 866     SvSETMAGIC(TOPs);
 867     return NORMAL;
 868 }
 869
 870 PP(pp_postinc)
 871 {
 872     dVAR; dSP; dTARGET;
 873     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 874         DIE(aTHX_ PL_no_modify);
 875     sv_setsv(TARG, TOPs);
 876     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 877         && SvIVX(TOPs) != IV_MAX)
 878     {
 879         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 880         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 881     }
 882     else
 883         sv_inc(TOPs);
 884     SvSETMAGIC(TOPs);
 885     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
 886     if (!SvOK(TARG))
 887         sv_setiv(TARG, 0);
 888     SETs(TARG);
 889     return NORMAL;
 890 }
 891
 892 PP(pp_postdec)
 893 {
 894     dVAR; dSP; dTARGET;
 895     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 896         DIE(aTHX_ PL_no_modify);
 897     sv_setsv(TARG, TOPs);
 898     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 899         && SvIVX(TOPs) != IV_MIN)
 900     {
 901         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 902         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 903     }
 904     else
 905         sv_dec(TOPs);
 906     SvSETMAGIC(TOPs);
 907     SETs(TARG);
 908     return NORMAL;
 909 }
 910
 911 /* Ordinary operators. */
 912
 913 PP(pp_pow)
 914 {
 915     dVAR; dSP; dATARGET;
 916 #ifdef PERL_PRESERVE_IVUV
 917     bool is_int = 0;
 918 #endif
 919     tryAMAGICbin(pow,opASSIGN);
 920 #ifdef PERL_PRESERVE_IVUV
 921     /* For integer to integer power, we do the calculation by hand wherever
 922        we're sure it is safe; otherwise we call pow() and try to convert to
 923        integer afterwards. */
 924     {
 925         SvIV_please(TOPs);
 926         if (SvIOK(TOPs)) {
 927             SvIV_please(TOPm1s);
 928             if (SvIOK(TOPm1s)) {
 929                 UV power;
 930                 bool baseuok;
 931                 UV baseuv;
 932
 933                 if (SvUOK(TOPs)) {
 934                     power = SvUVX(TOPs);
 935                 } else {
 936                     const IV iv = SvIVX(TOPs);
 937                     if (iv >= 0) {
 938                         power = iv;
 939                     } else {
 940                         goto float_it; /* Can't do negative powers this way.  */
 941                     }
 942                 }
 943
 944                 baseuok = SvUOK(TOPm1s);
 945                 if (baseuok) {
 946                     baseuv = SvUVX(TOPm1s);
 947                 } else {
 948                     const IV iv = SvIVX(TOPm1s);
 949                     if (iv >= 0) {
 950                         baseuv = iv;
 951                         baseuok = TRUE; /* effectively it's a UV now */
 952                     } else {
 953                         baseuv = -iv; /* abs, baseuok == false records sign */
 954                     }
 955                 }
 956                 /* now we have integer ** positive integer. */
 957                 is_int = 1;
 958
 959                 /* foo & (foo - 1) is zero only for a power of 2.  */
 960                 if (!(baseuv & (baseuv - 1))) {
 961                     /* We are raising power-of-2 to a positive integer.
 962                        The logic here will work for any base (even non-integer
 963                        bases) but it can be less accurate than
 964                        pow (base,power) or exp (power * log (base)) when the
 965                        intermediate values start to spill out of the mantissa.
 966                        With powers of 2 we know this can't happen.
 967                        And powers of 2 are the favourite thing for perl
 968                        programmers to notice ** not doing what they mean. */
 969                     NV result = 1.0;
 970                     NV base = baseuok ? baseuv : -(NV)baseuv;
 971
 972                     if (power & 1) {
 973                         result *= base;
 974                     }
 975                     while (power >>= 1) {
 976                         base *= base;
 977                         if (power & 1) {
 978                             result *= base;
 979                         }
 980                     }
 981                     SP--;
 982                     SETn( result );
 983                     SvIV_please(TOPs);
 984                     RETURN;
 985                 } else {
 986                     register unsigned int highbit = 8 * sizeof(UV);
 987                     register unsigned int diff = 8 * sizeof(UV);
 988                     while (diff >>= 1) {
 989                         highbit -= diff;
 990                         if (baseuv >> highbit) {
 991                             highbit += diff;
 992                         }
 993                     }
 994                     /* we now have baseuv < 2 ** highbit */
 995                     if (power * highbit <= 8 * sizeof(UV)) {
 996                         /* result will definitely fit in UV, so use UV math
 997                            on same algorithm as above */
 998                         register UV result = 1;
 999                         register UV base = baseuv;
1000                         const bool odd_power = (bool)(power & 1);
1001                         if (odd_power) {
1002                             result *= base;
1003                         }
1004                         while (power >>= 1) {
1005                             base *= base;
1006                             if (power & 1) {
1007                                 result *= base;
1008                             }
1009                         }
1010                         SP--;
1011                         if (baseuok || !odd_power)
1012                             /* answer is positive */
1013                             SETu( result );
1014                         else if (result <= (UV)IV_MAX)
1015                             /* answer negative, fits in IV */
1016                             SETi( -(IV)result );
1017                         else if (result == (UV)IV_MIN)
1018                             /* 2's complement assumption: special case IV_MIN */
1019                             SETi( IV_MIN );
1020                         else
1021                             /* answer negative, doesn't fit */
1022                             SETn( -(NV)result );
1023                         RETURN;
1024                     }
1025                 }
1026             }
1027         }
1028     }
1029   float_it:
1030 #endif
1031     {
1032         dPOPTOPnnrl;
1033
1034 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1035     /*
1036     We are building perl with long double support and are on an AIX OS
1037     afflicted with a powl() function that wrongly returns NaNQ for any
1038     negative base.  This was reported to IBM as PMR #23047-379 on
1039     03/06/2006.  The problem exists in at least the following versions
1040     of AIX and the libm fileset, and no doubt others as well:
1041
1042         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1043         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1044         AIX 5.2.0           bos.adt.libm 5.2.0.85
1045
1046     So, until IBM fixes powl(), we provide the following workaround to
1047     handle the problem ourselves.  Our logic is as follows: for
1048     negative bases (left), we use fmod(right, 2) to check if the
1049     exponent is an odd or even integer:
1050
1051         - if odd,  powl(left, right) == -powl(-left, right)
1052         - if even, powl(left, right) ==  powl(-left, right)
1053
1054     If the exponent is not an integer, the result is rightly NaNQ, so
1055     we just return that (as NV_NAN).
1056     */
1057
1058         if (left < 0.0) {
1059             NV mod2 = Perl_fmod( right, 2.0 );
1060             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1061                 SETn( -Perl_pow( -left, right) );
1062             } else if (mod2 == 0.0) {           /* even integer */
1063                 SETn( Perl_pow( -left, right) );
1064             } else {                            /* fractional power */
1065                 SETn( NV_NAN );
1066             }
1067         } else {
1068             SETn( Perl_pow( left, right) );
1069         }
1070 #else
1071         SETn( Perl_pow( left, right) );
1072 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1073
1074 #ifdef PERL_PRESERVE_IVUV
1075         if (is_int)
1076             SvIV_please(TOPs);
1077 #endif
1078         RETURN;
1079     }
1080 }
1081
1082 PP(pp_multiply)
1083 {
1084     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1085 #ifdef PERL_PRESERVE_IVUV
1086     SvIV_please(TOPs);
1087     if (SvIOK(TOPs)) {
1088         /* Unless the left argument is integer in range we are going to have to
1089            use NV maths. Hence only attempt to coerce the right argument if
1090            we know the left is integer.  */
1091         /* Left operand is defined, so is it IV? */
1092         SvIV_please(TOPm1s);
1093         if (SvIOK(TOPm1s)) {
1094             bool auvok = SvUOK(TOPm1s);
1095             bool buvok = SvUOK(TOPs);
1096             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1097             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1098             UV alow;
1099             UV ahigh;
1100             UV blow;
1101             UV bhigh;
1102
1103             if (auvok) {
1104                 alow = SvUVX(TOPm1s);
1105             } else {
1106                 const IV aiv = SvIVX(TOPm1s);
1107                 if (aiv >= 0) {
1108                     alow = aiv;
1109                     auvok = TRUE; /* effectively it's a UV now */
1110                 } else {
1111                     alow = -aiv; /* abs, auvok == false records sign */
1112                 }
1113             }
1114             if (buvok) {
1115                 blow = SvUVX(TOPs);
1116             } else {
1117                 const IV biv = SvIVX(TOPs);
1118                 if (biv >= 0) {
1119                     blow = biv;
1120                     buvok = TRUE; /* effectively it's a UV now */
1121                 } else {
1122                     blow = -biv; /* abs, buvok == false records sign */
1123                 }
1124             }
1125
1126             /* If this does sign extension on unsigned it's time for plan B  */
1127             ahigh = alow >> (4 * sizeof (UV));
1128             alow &= botmask;
1129             bhigh = blow >> (4 * sizeof (UV));
1130             blow &= botmask;
1131             if (ahigh && bhigh) {
1132                 NOOP;
1133                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1134                    which is overflow. Drop to NVs below.  */
1135             } else if (!ahigh && !bhigh) {
1136                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1137                    so the unsigned multiply cannot overflow.  */
1138                 const UV product = alow * blow;
1139                 if (auvok == buvok) {
1140                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1141                     SP--;
1142                     SETu( product );
1143                     RETURN;
1144                 } else if (product <= (UV)IV_MIN) {
1145                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1146                     /* -ve result, which could overflow an IV  */
1147                     SP--;
1148                     SETi( -(IV)product );
1149                     RETURN;
1150                 } /* else drop to NVs below. */
1151             } else {
1152                 /* One operand is large, 1 small */
1153                 UV product_middle;
1154                 if (bhigh) {
1155                     /* swap the operands */
1156                     ahigh = bhigh;
1157                     bhigh = blow; /* bhigh now the temp var for the swap */
1158                     blow = alow;
1159                     alow = bhigh;
1160                 }
1161                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1162                    multiplies can't overflow. shift can, add can, -ve can.  */
1163                 product_middle = ahigh * blow;
1164                 if (!(product_middle & topmask)) {
1165                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1166                     UV product_low;
1167                     product_middle <<= (4 * sizeof (UV));
1168                     product_low = alow * blow;
1169
1170                     /* as for pp_add, UV + something mustn't get smaller.
1171                        IIRC ANSI mandates this wrapping *behaviour* for
1172                        unsigned whatever the actual representation*/
1173                     product_low += product_middle;
1174                     if (product_low >= product_middle) {
1175                         /* didn't overflow */
1176                         if (auvok == buvok) {
1177                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1178                             SP--;
1179                             SETu( product_low );
1180                             RETURN;
1181                         } else if (product_low <= (UV)IV_MIN) {
1182                             /* 2s complement assumption again  */
1183                             /* -ve result, which could overflow an IV  */
1184                             SP--;
1185                             SETi( -(IV)product_low );
1186                             RETURN;
1187                         } /* else drop to NVs below. */
1188                     }
1189                 } /* product_middle too large */
1190             } /* ahigh && bhigh */
1191         } /* SvIOK(TOPm1s) */
1192     } /* SvIOK(TOPs) */
1193 #endif
1194     {
1195       dPOPTOPnnrl;
1196       SETn( left * right );
1197       RETURN;
1198     }
1199 }
1200
1201 PP(pp_divide)
1202 {
1203     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1204     /* Only try to do UV divide first
1205        if ((SLOPPYDIVIDE is true) or
1206            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1207             to preserve))
1208        The assumption is that it is better to use floating point divide
1209        whenever possible, only doing integer divide first if we can't be sure.
1210        If NV_PRESERVES_UV is true then we know at compile time that no UV
1211        can be too large to preserve, so don't need to compile the code to
1212        test the size of UVs.  */
1213
1214 #ifdef SLOPPYDIVIDE
1215 #  define PERL_TRY_UV_DIVIDE
1216     /* ensure that 20./5. == 4. */
1217 #else
1218 #  ifdef PERL_PRESERVE_IVUV
1219 #    ifndef NV_PRESERVES_UV
1220 #      define PERL_TRY_UV_DIVIDE
1221 #    endif
1222 #  endif
1223 #endif
1224
1225 #ifdef PERL_TRY_UV_DIVIDE
1226     SvIV_please(TOPs);
1227     if (SvIOK(TOPs)) {
1228         SvIV_please(TOPm1s);
1229         if (SvIOK(TOPm1s)) {
1230             bool left_non_neg = SvUOK(TOPm1s);
1231             bool right_non_neg = SvUOK(TOPs);
1232             UV left;
1233             UV right;
1234
1235             if (right_non_neg) {
1236                 right = SvUVX(TOPs);
1237             }
1238             else {
1239                 const IV biv = SvIVX(TOPs);
1240                 if (biv >= 0) {
1241                     right = biv;
1242                     right_non_neg = TRUE; /* effectively it's a UV now */
1243                 }
1244                 else {
1245                     right = -biv;
1246                 }
1247             }
1248             /* historically undef()/0 gives a "Use of uninitialized value"
1249                warning before dieing, hence this test goes here.
1250                If it were immediately before the second SvIV_please, then
1251                DIE() would be invoked before left was even inspected, so
1252                no inpsection would give no warning.  */
1253             if (right == 0)
1254                 DIE(aTHX_ "Illegal division by zero");
1255
1256             if (left_non_neg) {
1257                 left = SvUVX(TOPm1s);
1258             }
1259             else {
1260                 const IV aiv = SvIVX(TOPm1s);
1261                 if (aiv >= 0) {
1262                     left = aiv;
1263                     left_non_neg = TRUE; /* effectively it's a UV now */
1264                 }
1265                 else {
1266                     left = -aiv;
1267                 }
1268             }
1269
1270             if (left >= right
1271 #ifdef SLOPPYDIVIDE
1272                 /* For sloppy divide we always attempt integer division.  */
1273 #else
1274                 /* Otherwise we only attempt it if either or both operands
1275                    would not be preserved by an NV.  If both fit in NVs
1276                    we fall through to the NV divide code below.  However,
1277                    as left >= right to ensure integer result here, we know that
1278                    we can skip the test on the right operand - right big
1279                    enough not to be preserved can't get here unless left is
1280                    also too big.  */
1281
1282                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1283 #endif
1284                 ) {
1285                 /* Integer division can't overflow, but it can be imprecise.  */
1286                 const UV result = left / right;
1287                 if (result * right == left) {
1288                     SP--; /* result is valid */
1289                     if (left_non_neg == right_non_neg) {
1290                         /* signs identical, result is positive.  */
1291                         SETu( result );
1292                         RETURN;
1293                     }
1294                     /* 2s complement assumption */
1295                     if (result <= (UV)IV_MIN)
1296                         SETi( -(IV)result );
1297                     else {
1298                         /* It's exact but too negative for IV. */
1299                         SETn( -(NV)result );
1300                     }
1301                     RETURN;
1302                 } /* tried integer divide but it was not an integer result */
1303             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1304         } /* left wasn't SvIOK */
1305     } /* right wasn't SvIOK */
1306 #endif /* PERL_TRY_UV_DIVIDE */
1307     {
1308         dPOPPOPnnrl;
1309 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1310         if (! Perl_isnan(right) && right == 0.0)
1311 #else
1312         if (right == 0.0)
1313 #endif
1314             DIE(aTHX_ "Illegal division by zero");
1315         PUSHn( left / right );
1316         RETURN;
1317     }
1318 }
1319
1320 PP(pp_modulo)
1321 {
1322     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1323     {
1324         UV left  = 0;
1325         UV right = 0;
1326         bool left_neg = FALSE;
1327         bool right_neg = FALSE;
1328         bool use_double = FALSE;
1329         bool dright_valid = FALSE;
1330         NV dright = 0.0;
1331         NV dleft  = 0.0;
1332
1333         SvIV_please(TOPs);
1334         if (SvIOK(TOPs)) {
1335             right_neg = !SvUOK(TOPs);
1336             if (!right_neg) {
1337                 right = SvUVX(POPs);
1338             } else {
1339                 const IV biv = SvIVX(POPs);
1340                 if (biv >= 0) {
1341                     right = biv;
1342                     right_neg = FALSE; /* effectively it's a UV now */
1343                 } else {
1344                     right = -biv;
1345                 }
1346             }
1347         }
1348         else {
1349             dright = POPn;
1350             right_neg = dright < 0;
1351             if (right_neg)
1352                 dright = -dright;
1353             if (dright < UV_MAX_P1) {
1354                 right = U_V(dright);
1355                 dright_valid = TRUE; /* In case we need to use double below.  */
1356             } else {
1357                 use_double = TRUE;
1358             }
1359         }
1360
1361         /* At this point use_double is only true if right is out of range for
1362            a UV.  In range NV has been rounded down to nearest UV and
1363            use_double false.  */
1364         SvIV_please(TOPs);
1365         if (!use_double && SvIOK(TOPs)) {
1366             if (SvIOK(TOPs)) {
1367                 left_neg = !SvUOK(TOPs);
1368                 if (!left_neg) {
1369                     left = SvUVX(POPs);
1370                 } else {
1371                     const IV aiv = SvIVX(POPs);
1372                     if (aiv >= 0) {
1373                         left = aiv;
1374                         left_neg = FALSE; /* effectively it's a UV now */
1375                     } else {
1376                         left = -aiv;
1377                     }
1378                 }
1379             }
1380         }
1381         else {
1382             dleft = POPn;
1383             left_neg = dleft < 0;
1384             if (left_neg)
1385                 dleft = -dleft;
1386
1387             /* This should be exactly the 5.6 behaviour - if left and right are
1388                both in range for UV then use U_V() rather than floor.  */
1389             if (!use_double) {
1390                 if (dleft < UV_MAX_P1) {
1391                     /* right was in range, so is dleft, so use UVs not double.
1392                      */
1393                     left = U_V(dleft);
1394                 }
1395                 /* left is out of range for UV, right was in range, so promote
1396                    right (back) to double.  */
1397                 else {
1398                     /* The +0.5 is used in 5.6 even though it is not strictly
1399                        consistent with the implicit +0 floor in the U_V()
1400                        inside the #if 1. */
1401                     dleft = Perl_floor(dleft + 0.5);
1402                     use_double = TRUE;
1403                     if (dright_valid)
1404                         dright = Perl_floor(dright + 0.5);
1405                     else
1406                         dright = right;
1407                 }
1408             }
1409         }
1410         if (use_double) {
1411             NV dans;
1412
1413             if (!dright)
1414                 DIE(aTHX_ "Illegal modulus zero");
1415
1416             dans = Perl_fmod(dleft, dright);
1417             if ((left_neg != right_neg) && dans)
1418                 dans = dright - dans;
1419             if (right_neg)
1420                 dans = -dans;
1421             sv_setnv(TARG, dans);
1422         }
1423         else {
1424             UV ans;
1425
1426             if (!right)
1427                 DIE(aTHX_ "Illegal modulus zero");
1428
1429             ans = left % right;
1430             if ((left_neg != right_neg) && ans)
1431                 ans = right - ans;
1432             if (right_neg) {
1433                 /* XXX may warn: unary minus operator applied to unsigned type */
1434                 /* could change -foo to be (~foo)+1 instead     */
1435                 if (ans <= ~((UV)IV_MAX)+1)
1436                     sv_setiv(TARG, ~ans+1);
1437                 else
1438                     sv_setnv(TARG, -(NV)ans);
1439             }
1440             else
1441                 sv_setuv(TARG, ans);
1442         }
1443         PUSHTARG;
1444         RETURN;
1445     }
1446 }
1447
1448 PP(pp_repeat)
1449 {
1450   dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1451   {
1452     register IV count;
1453     dPOPss;
1454     SvGETMAGIC(sv);
1455     if (SvIOKp(sv)) {
1456          if (SvUOK(sv)) {
1457               const UV uv = SvUV(sv);
1458               if (uv > IV_MAX)
1459                    count = IV_MAX; /* The best we can do? */
1460               else
1461                    count = uv;
1462          } else {
1463               const IV iv = SvIV(sv);
1464               if (iv < 0)
1465                    count = 0;
1466               else
1467                    count = iv;
1468          }
1469     }
1470     else if (SvNOKp(sv)) {
1471          const NV nv = SvNV(sv);
1472          if (nv < 0.0)
1473               count = 0;
1474          else
1475               count = (IV)nv;
1476     }
1477     else
1478          count = SvIV(sv);
1479     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1480         dMARK;
1481         static const char oom_list_extend[] = "Out of memory during list extend";
1482         const I32 items = SP - MARK;
1483         const I32 max = items * count;
1484
1485         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1486         /* Did the max computation overflow? */
1487         if (items > 0 && max > 0 && (max < items || max < count))
1488            Perl_croak(aTHX_ oom_list_extend);
1489         MEXTEND(MARK, max);
1490         if (count > 1) {
1491             while (SP > MARK) {
1492 #if 0
1493               /* This code was intended to fix 20010809.028:
1494
1495                  $x = 'abcd';
1496                  for (($x =~ /./g) x 2) {
1497                      print chop; # "abcdabcd" expected as output.
1498                  }
1499
1500                * but that change (#11635) broke this code:
1501
1502                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1503
1504                * I can't think of a better fix that doesn't introduce
1505                * an efficiency hit by copying the SVs. The stack isn't
1506                * refcounted, and mortalisation obviously doesn't
1507                * Do The Right Thing when the stack has more than
1508                * one pointer to the same mortal value.
1509                * .robin.
1510                */
1511                 if (*SP) {
1512                     *SP = sv_2mortal(newSVsv(*SP));
1513                     SvREADONLY_on(*SP);
1514                 }
1515 #else
1516                if (*SP)
1517                    SvTEMP_off((*SP));
1518 #endif
1519                 SP--;
1520             }
1521             MARK++;
1522             repeatcpy((char*)(MARK + items), (char*)MARK,
1523                 items * sizeof(SV*), count - 1);
1524             SP += max;
1525         }
1526         else if (count <= 0)
1527             SP -= items;
1528     }
1529     else {      /* Note: mark already snarfed by pp_list */
1530         SV * const tmpstr = POPs;
1531         STRLEN len;
1532         bool isutf;
1533         static const char oom_string_extend[] =
1534           "Out of memory during string extend";
1535
1536         SvSetSV(TARG, tmpstr);
1537         SvPV_force(TARG, len);
1538         isutf = DO_UTF8(TARG);
1539         if (count != 1) {
1540             if (count < 1)
1541                 SvCUR_set(TARG, 0);
1542             else {
1543                 const STRLEN max = (UV)count * len;
1544                 if (len > MEM_SIZE_MAX / count)
1545                      Perl_croak(aTHX_ oom_string_extend);
1546                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1547                 SvGROW(TARG, max + 1);
1548                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1549                 SvCUR_set(TARG, SvCUR(TARG) * count);
1550             }
1551             *SvEND(TARG) = '\0';
1552         }
1553         if (isutf)
1554             (void)SvPOK_only_UTF8(TARG);
1555         else
1556             (void)SvPOK_only(TARG);
1557
1558         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1559             /* The parser saw this as a list repeat, and there
1560                are probably several items on the stack. But we're
1561                in scalar context, and there's no pp_list to save us
1562                now. So drop the rest of the items -- robin@kitsite.com
1563              */
1564             dMARK;
1565             SP = MARK;
1566         }
1567         PUSHTARG;
1568     }
1569     RETURN;
1570   }
1571 }
1572
1573 PP(pp_subtract)
1574 {
1575     dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1576     useleft = USE_LEFT(TOPm1s);
1577 #ifdef PERL_PRESERVE_IVUV
1578     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1579        "bad things" happen if you rely on signed integers wrapping.  */
1580     SvIV_please(TOPs);
1581     if (SvIOK(TOPs)) {
1582         /* Unless the left argument is integer in range we are going to have to
1583            use NV maths. Hence only attempt to coerce the right argument if
1584            we know the left is integer.  */
1585         register UV auv = 0;
1586         bool auvok = FALSE;
1587         bool a_valid = 0;
1588
1589         if (!useleft) {
1590             auv = 0;
1591             a_valid = auvok = 1;
1592             /* left operand is undef, treat as zero.  */
1593         } else {
1594             /* Left operand is defined, so is it IV? */
1595             SvIV_please(TOPm1s);
1596             if (SvIOK(TOPm1s)) {
1597                 if ((auvok = SvUOK(TOPm1s)))
1598                     auv = SvUVX(TOPm1s);
1599                 else {
1600                     register const IV aiv = SvIVX(TOPm1s);
1601                     if (aiv >= 0) {
1602                         auv = aiv;
1603                         auvok = 1;      /* Now acting as a sign flag.  */
1604                     } else { /* 2s complement assumption for IV_MIN */
1605                         auv = (UV)-aiv;
1606                     }
1607                 }
1608                 a_valid = 1;
1609             }
1610         }
1611         if (a_valid) {
1612             bool result_good = 0;
1613             UV result;
1614             register UV buv;
1615             bool buvok = SvUOK(TOPs);
1616
1617             if (buvok)
1618                 buv = SvUVX(TOPs);
1619             else {
1620                 register const IV biv = SvIVX(TOPs);
1621                 if (biv >= 0) {
1622                     buv = biv;
1623                     buvok = 1;
1624                 } else
1625                     buv = (UV)-biv;
1626             }
1627             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1628                else "IV" now, independent of how it came in.
1629                if a, b represents positive, A, B negative, a maps to -A etc
1630                a - b =>  (a - b)
1631                A - b => -(a + b)
1632                a - B =>  (a + b)
1633                A - B => -(a - b)
1634                all UV maths. negate result if A negative.
1635                subtract if signs same, add if signs differ. */
1636
1637             if (auvok ^ buvok) {
1638                 /* Signs differ.  */
1639                 result = auv + buv;
1640                 if (result >= auv)
1641                     result_good = 1;
1642             } else {
1643                 /* Signs same */
1644                 if (auv >= buv) {
1645                     result = auv - buv;
1646                     /* Must get smaller */
1647                     if (result <= auv)
1648                         result_good = 1;
1649                 } else {
1650                     result = buv - auv;
1651                     if (result <= buv) {
1652                         /* result really should be -(auv-buv). as its negation
1653                            of true value, need to swap our result flag  */
1654                         auvok = !auvok;
1655                         result_good = 1;
1656                     }
1657                 }
1658             }
1659             if (result_good) {
1660                 SP--;
1661                 if (auvok)
1662                     SETu( result );
1663                 else {
1664                     /* Negate result */
1665                     if (result <= (UV)IV_MIN)
1666                         SETi( -(IV)result );
1667                     else {
1668                         /* result valid, but out of range for IV.  */
1669                         SETn( -(NV)result );
1670                     }
1671                 }
1672                 RETURN;
1673             } /* Overflow, drop through to NVs.  */
1674         }
1675     }
1676 #endif
1677     useleft = USE_LEFT(TOPm1s);
1678     {
1679         dPOPnv;
1680         if (!useleft) {
1681             /* left operand is undef, treat as zero - value */
1682             SETn(-value);
1683             RETURN;
1684         }
1685         SETn( TOPn - value );
1686         RETURN;
1687     }
1688 }
1689
1690 PP(pp_left_shift)
1691 {
1692     dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1693     {
1694       const IV shift = POPi;
1695       if (PL_op->op_private & HINT_INTEGER) {
1696         const IV i = TOPi;
1697         SETi(i << shift);
1698       }
1699       else {
1700         const UV u = TOPu;
1701         SETu(u << shift);
1702       }
1703       RETURN;
1704     }
1705 }
1706
1707 PP(pp_right_shift)
1708 {
1709     dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1710     {
1711       const IV shift = POPi;
1712       if (PL_op->op_private & HINT_INTEGER) {
1713         const IV i = TOPi;
1714         SETi(i >> shift);
1715       }
1716       else {
1717         const UV u = TOPu;
1718         SETu(u >> shift);
1719       }
1720       RETURN;
1721     }
1722 }
1723
1724 PP(pp_lt)
1725 {
1726     dVAR; dSP; tryAMAGICbinSET(lt,0);
1727 #ifdef PERL_PRESERVE_IVUV
1728     SvIV_please(TOPs);
1729     if (SvIOK(TOPs)) {
1730         SvIV_please(TOPm1s);
1731         if (SvIOK(TOPm1s)) {
1732             bool auvok = SvUOK(TOPm1s);
1733             bool buvok = SvUOK(TOPs);
1734
1735             if (!auvok && !buvok) { /* ## IV < IV ## */
1736                 const IV aiv = SvIVX(TOPm1s);
1737                 const IV biv = SvIVX(TOPs);
1738
1739                 SP--;
1740                 SETs(boolSV(aiv < biv));
1741                 RETURN;
1742             }
1743             if (auvok && buvok) { /* ## UV < UV ## */
1744                 const UV auv = SvUVX(TOPm1s);
1745                 const UV buv = SvUVX(TOPs);
1746
1747                 SP--;
1748                 SETs(boolSV(auv < buv));
1749                 RETURN;
1750             }
1751             if (auvok) { /* ## UV < IV ## */
1752                 UV auv;
1753                 const IV biv = SvIVX(TOPs);
1754                 SP--;
1755                 if (biv < 0) {
1756                     /* As (a) is a UV, it's >=0, so it cannot be < */
1757                     SETs(&PL_sv_no);
1758                     RETURN;
1759                 }
1760                 auv = SvUVX(TOPs);
1761                 SETs(boolSV(auv < (UV)biv));
1762                 RETURN;
1763             }
1764             { /* ## IV < UV ## */
1765                 const IV aiv = SvIVX(TOPm1s);
1766                 UV buv;
1767
1768                 if (aiv < 0) {
1769                     /* As (b) is a UV, it's >=0, so it must be < */
1770                     SP--;
1771                     SETs(&PL_sv_yes);
1772                     RETURN;
1773                 }
1774                 buv = SvUVX(TOPs);
1775                 SP--;
1776                 SETs(boolSV((UV)aiv < buv));
1777                 RETURN;
1778             }
1779         }
1780     }
1781 #endif
1782 #ifndef NV_PRESERVES_UV
1783 #ifdef PERL_PRESERVE_IVUV
1784     else
1785 #endif
1786     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1787         SP--;
1788         SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1789         RETURN;
1790     }
1791 #endif
1792     {
1793 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1794       dPOPTOPnnrl;
1795       if (Perl_isnan(left) || Perl_isnan(right))
1796           RETSETNO;
1797       SETs(boolSV(left < right));
1798 #else
1799       dPOPnv;
1800       SETs(boolSV(TOPn < value));
1801 #endif
1802       RETURN;
1803     }
1804 }
1805
1806 PP(pp_gt)
1807 {
1808     dVAR; dSP; tryAMAGICbinSET(gt,0);
1809 #ifdef PERL_PRESERVE_IVUV
1810     SvIV_please(TOPs);
1811     if (SvIOK(TOPs)) {
1812         SvIV_please(TOPm1s);
1813         if (SvIOK(TOPm1s)) {
1814             bool auvok = SvUOK(TOPm1s);
1815             bool buvok = SvUOK(TOPs);
1816
1817             if (!auvok && !buvok) { /* ## IV > IV ## */
1818                 const IV aiv = SvIVX(TOPm1s);
1819                 const IV biv = SvIVX(TOPs);
1820
1821                 SP--;
1822                 SETs(boolSV(aiv > biv));
1823                 RETURN;
1824             }
1825             if (auvok && buvok) { /* ## UV > UV ## */
1826                 const UV auv = SvUVX(TOPm1s);
1827                 const UV buv = SvUVX(TOPs);
1828
1829                 SP--;
1830                 SETs(boolSV(auv > buv));
1831                 RETURN;
1832             }
1833             if (auvok) { /* ## UV > IV ## */
1834                 UV auv;
1835                 const IV biv = SvIVX(TOPs);
1836
1837                 SP--;
1838                 if (biv < 0) {
1839                     /* As (a) is a UV, it's >=0, so it must be > */
1840                     SETs(&PL_sv_yes);
1841                     RETURN;
1842                 }
1843                 auv = SvUVX(TOPs);
1844                 SETs(boolSV(auv > (UV)biv));
1845                 RETURN;
1846             }
1847             { /* ## IV > UV ## */
1848                 const IV aiv = SvIVX(TOPm1s);
1849                 UV buv;
1850
1851                 if (aiv < 0) {
1852                     /* As (b) is a UV, it's >=0, so it cannot be > */
1853                     SP--;
1854                     SETs(&PL_sv_no);
1855                     RETURN;
1856                 }
1857                 buv = SvUVX(TOPs);
1858                 SP--;
1859                 SETs(boolSV((UV)aiv > buv));
1860                 RETURN;
1861             }
1862         }
1863     }
1864 #endif
1865 #ifndef NV_PRESERVES_UV
1866 #ifdef PERL_PRESERVE_IVUV
1867     else
1868 #endif
1869     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1870         SP--;
1871         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1872         RETURN;
1873     }
1874 #endif
1875     {
1876 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1877       dPOPTOPnnrl;
1878       if (Perl_isnan(left) || Perl_isnan(right))
1879           RETSETNO;
1880       SETs(boolSV(left > right));
1881 #else
1882       dPOPnv;
1883       SETs(boolSV(TOPn > value));
1884 #endif
1885       RETURN;
1886     }
1887 }
1888
1889 PP(pp_le)
1890 {
1891     dVAR; dSP; tryAMAGICbinSET(le,0);
1892 #ifdef PERL_PRESERVE_IVUV
1893     SvIV_please(TOPs);
1894     if (SvIOK(TOPs)) {
1895         SvIV_please(TOPm1s);
1896         if (SvIOK(TOPm1s)) {
1897             bool auvok = SvUOK(TOPm1s);
1898             bool buvok = SvUOK(TOPs);
1899
1900             if (!auvok && !buvok) { /* ## IV <= IV ## */
1901                 const IV aiv = SvIVX(TOPm1s);
1902                 const IV biv = SvIVX(TOPs);
1903
1904                 SP--;
1905                 SETs(boolSV(aiv <= biv));
1906                 RETURN;
1907             }
1908             if (auvok && buvok) { /* ## UV <= UV ## */
1909                 UV auv = SvUVX(TOPm1s);
1910                 UV buv = SvUVX(TOPs);
1911
1912                 SP--;
1913                 SETs(boolSV(auv <= buv));
1914                 RETURN;
1915             }
1916             if (auvok) { /* ## UV <= IV ## */
1917                 UV auv;
1918                 const IV biv = SvIVX(TOPs);
1919
1920                 SP--;
1921                 if (biv < 0) {
1922                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1923                     SETs(&PL_sv_no);
1924                     RETURN;
1925                 }
1926                 auv = SvUVX(TOPs);
1927                 SETs(boolSV(auv <= (UV)biv));
1928                 RETURN;
1929             }
1930             { /* ## IV <= UV ## */
1931                 const IV aiv = SvIVX(TOPm1s);
1932                 UV buv;
1933
1934                 if (aiv < 0) {
1935                     /* As (b) is a UV, it's >=0, so a must be <= */
1936                     SP--;
1937                     SETs(&PL_sv_yes);
1938                     RETURN;
1939                 }
1940                 buv = SvUVX(TOPs);
1941                 SP--;
1942                 SETs(boolSV((UV)aiv <= buv));
1943                 RETURN;
1944             }
1945         }
1946     }
1947 #endif
1948 #ifndef NV_PRESERVES_UV
1949 #ifdef PERL_PRESERVE_IVUV
1950     else
1951 #endif
1952     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1953         SP--;
1954         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1955         RETURN;
1956     }
1957 #endif
1958     {
1959 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1960       dPOPTOPnnrl;
1961       if (Perl_isnan(left) || Perl_isnan(right))
1962           RETSETNO;
1963       SETs(boolSV(left <= right));
1964 #else
1965       dPOPnv;
1966       SETs(boolSV(TOPn <= value));
1967 #endif
1968       RETURN;
1969     }
1970 }
1971
1972 PP(pp_ge)
1973 {
1974     dVAR; dSP; tryAMAGICbinSET(ge,0);
1975 #ifdef PERL_PRESERVE_IVUV
1976     SvIV_please(TOPs);
1977     if (SvIOK(TOPs)) {
1978         SvIV_please(TOPm1s);
1979         if (SvIOK(TOPm1s)) {
1980             bool auvok = SvUOK(TOPm1s);
1981             bool buvok = SvUOK(TOPs);
1982
1983             if (!auvok && !buvok) { /* ## IV >= IV ## */
1984                 const IV aiv = SvIVX(TOPm1s);
1985                 const IV biv = SvIVX(TOPs);
1986
1987                 SP--;
1988                 SETs(boolSV(aiv >= biv));
1989                 RETURN;
1990             }
1991             if (auvok && buvok) { /* ## UV >= UV ## */
1992                 const UV auv = SvUVX(TOPm1s);
1993                 const UV buv = SvUVX(TOPs);
1994
1995                 SP--;
1996                 SETs(boolSV(auv >= buv));
1997                 RETURN;
1998             }
1999             if (auvok) { /* ## UV >= IV ## */
2000                 UV auv;
2001                 const IV biv = SvIVX(TOPs);
2002
2003                 SP--;
2004                 if (biv < 0) {
2005                     /* As (a) is a UV, it's >=0, so it must be >= */
2006                     SETs(&PL_sv_yes);
2007                     RETURN;
2008                 }
2009                 auv = SvUVX(TOPs);
2010                 SETs(boolSV(auv >= (UV)biv));
2011                 RETURN;
2012             }
2013             { /* ## IV >= UV ## */
2014                 const IV aiv = SvIVX(TOPm1s);
2015                 UV buv;
2016
2017                 if (aiv < 0) {
2018                     /* As (b) is a UV, it's >=0, so a cannot be >= */
2019                     SP--;
2020                     SETs(&PL_sv_no);
2021                     RETURN;
2022                 }
2023                 buv = SvUVX(TOPs);
2024                 SP--;
2025                 SETs(boolSV((UV)aiv >= buv));
2026                 RETURN;
2027             }
2028         }
2029     }
2030 #endif
2031 #ifndef NV_PRESERVES_UV
2032 #ifdef PERL_PRESERVE_IVUV
2033     else
2034 #endif
2035     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2036         SP--;
2037         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2038         RETURN;
2039     }
2040 #endif
2041     {
2042 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2043       dPOPTOPnnrl;
2044       if (Perl_isnan(left) || Perl_isnan(right))
2045           RETSETNO;
2046       SETs(boolSV(left >= right));
2047 #else
2048       dPOPnv;
2049       SETs(boolSV(TOPn >= value));
2050 #endif
2051       RETURN;
2052     }
2053 }
2054
2055 PP(pp_ne)
2056 {
2057     dVAR; dSP; tryAMAGICbinSET(ne,0);
2058 #ifndef NV_PRESERVES_UV
2059     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2060         SP--;
2061         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2062         RETURN;
2063     }
2064 #endif
2065 #ifdef PERL_PRESERVE_IVUV
2066     SvIV_please(TOPs);
2067     if (SvIOK(TOPs)) {
2068         SvIV_please(TOPm1s);
2069         if (SvIOK(TOPm1s)) {
2070             const bool auvok = SvUOK(TOPm1s);
2071             const bool buvok = SvUOK(TOPs);
2072
2073             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2074                 /* Casting IV to UV before comparison isn't going to matter
2075                    on 2s complement. On 1s complement or sign&magnitude
2076                    (if we have any of them) it could make negative zero
2077                    differ from normal zero. As I understand it. (Need to
2078                    check - is negative zero implementation defined behaviour
2079                    anyway?). NWC  */
2080                 const UV buv = SvUVX(POPs);
2081                 const UV auv = SvUVX(TOPs);
2082
2083                 SETs(boolSV(auv != buv));
2084                 RETURN;
2085             }
2086             {                   /* ## Mixed IV,UV ## */
2087                 IV iv;
2088                 UV uv;
2089
2090                 /* != is commutative so swap if needed (save code) */
2091                 if (auvok) {
2092                     /* swap. top of stack (b) is the iv */
2093                     iv = SvIVX(TOPs);
2094                     SP--;
2095                     if (iv < 0) {
2096                         /* As (a) is a UV, it's >0, so it cannot be == */
2097                         SETs(&PL_sv_yes);
2098                         RETURN;
2099                     }
2100                     uv = SvUVX(TOPs);
2101                 } else {
2102                     iv = SvIVX(TOPm1s);
2103                     SP--;
2104                     if (iv < 0) {
2105                         /* As (b) is a UV, it's >0, so it cannot be == */
2106                         SETs(&PL_sv_yes);
2107                         RETURN;
2108                     }
2109                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2110                 }
2111                 SETs(boolSV((UV)iv != uv));
2112                 RETURN;
2113             }
2114         }
2115     }
2116 #endif
2117     {
2118 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2119       dPOPTOPnnrl;
2120       if (Perl_isnan(left) || Perl_isnan(right))
2121           RETSETYES;
2122       SETs(boolSV(left != right));
2123 #else
2124       dPOPnv;
2125       SETs(boolSV(TOPn != value));
2126 #endif
2127       RETURN;
2128     }
2129 }
2130
2131 PP(pp_ncmp)
2132 {
2133     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2134 #ifndef NV_PRESERVES_UV
2135     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2136         const UV right = PTR2UV(SvRV(POPs));
2137         const UV left = PTR2UV(SvRV(TOPs));
2138         SETi((left > right) - (left < right));
2139         RETURN;
2140     }
2141 #endif
2142 #ifdef PERL_PRESERVE_IVUV
2143     /* Fortunately it seems NaN isn't IOK */
2144     SvIV_please(TOPs);
2145     if (SvIOK(TOPs)) {
2146         SvIV_please(TOPm1s);
2147         if (SvIOK(TOPm1s)) {
2148             const bool leftuvok = SvUOK(TOPm1s);
2149             const bool rightuvok = SvUOK(TOPs);
2150             I32 value;
2151             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2152                 const IV leftiv = SvIVX(TOPm1s);
2153                 const IV rightiv = SvIVX(TOPs);
2154
2155                 if (leftiv > rightiv)
2156                     value = 1;
2157                 else if (leftiv < rightiv)
2158                     value = -1;
2159                 else
2160                     value = 0;
2161             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2162                 const UV leftuv = SvUVX(TOPm1s);
2163                 const UV rightuv = SvUVX(TOPs);
2164
2165                 if (leftuv > rightuv)
2166                     value = 1;
2167                 else if (leftuv < rightuv)
2168                     value = -1;
2169                 else
2170                     value = 0;
2171             } else if (leftuvok) { /* ## UV <=> IV ## */
2172                 const IV rightiv = SvIVX(TOPs);
2173                 if (rightiv < 0) {
2174                     /* As (a) is a UV, it's >=0, so it cannot be < */
2175                     value = 1;
2176                 } else {
2177                     const UV leftuv = SvUVX(TOPm1s);
2178                     if (leftuv > (UV)rightiv) {
2179                         value = 1;
2180                     } else if (leftuv < (UV)rightiv) {
2181                         value = -1;
2182                     } else {
2183                         value = 0;
2184                     }
2185                 }
2186             } else { /* ## IV <=> UV ## */
2187                 const IV leftiv = SvIVX(TOPm1s);
2188                 if (leftiv < 0) {
2189                     /* As (b) is a UV, it's >=0, so it must be < */
2190                     value = -1;
2191                 } else {
2192                     const UV rightuv = SvUVX(TOPs);
2193                     if ((UV)leftiv > rightuv) {
2194                         value = 1;
2195                     } else if ((UV)leftiv < rightuv) {
2196                         value = -1;
2197                     } else {
2198                         value = 0;
2199                     }
2200                 }
2201             }
2202             SP--;
2203             SETi(value);
2204             RETURN;
2205         }
2206     }
2207 #endif
2208     {
2209       dPOPTOPnnrl;
2210       I32 value;
2211
2212 #ifdef Perl_isnan
2213       if (Perl_isnan(left) || Perl_isnan(right)) {
2214           SETs(&PL_sv_undef);
2215           RETURN;
2216        }
2217       value = (left > right) - (left < right);
2218 #else
2219       if (left == right)
2220         value = 0;
2221       else if (left < right)
2222         value = -1;
2223       else if (left > right)
2224         value = 1;
2225       else {
2226         SETs(&PL_sv_undef);
2227         RETURN;
2228       }
2229 #endif
2230       SETi(value);
2231       RETURN;
2232     }
2233 }
2234
2235 PP(pp_sle)
2236 {
2237     dVAR; dSP;
2238
2239     int amg_type = sle_amg;
2240     int multiplier = 1;
2241     int rhs = 1;
2242
2243     switch (PL_op->op_type) {
2244     case OP_SLT:
2245         amg_type = slt_amg;
2246         /* cmp < 0 */
2247         rhs = 0;
2248         break;
2249     case OP_SGT:
2250         amg_type = sgt_amg;
2251         /* cmp > 0 */
2252         multiplier = -1;
2253         rhs = 0;
2254         break;
2255     case OP_SGE:
2256         amg_type = sge_amg;
2257         /* cmp >= 0 */
2258         multiplier = -1;
2259         break;
2260     }
2261
2262     tryAMAGICbinSET_var(amg_type,0);
2263     {
2264       dPOPTOPssrl;
2265       const int cmp = (IN_LOCALE_RUNTIME
2266                  ? sv_cmp_locale(left, right)
2267                  : sv_cmp(left, right));
2268       SETs(boolSV(cmp * multiplier < rhs));
2269       RETURN;
2270     }
2271 }
2272
2273 PP(pp_seq)
2274 {
2275     dVAR; dSP; tryAMAGICbinSET(seq,0);
2276     {
2277       dPOPTOPssrl;
2278       SETs(boolSV(sv_eq(left, right)));
2279       RETURN;
2280     }
2281 }
2282
2283 PP(pp_sne)
2284 {
2285     dVAR; dSP; tryAMAGICbinSET(sne,0);
2286     {
2287       dPOPTOPssrl;
2288       SETs(boolSV(!sv_eq(left, right)));
2289       RETURN;
2290     }
2291 }
2292
2293 PP(pp_scmp)
2294 {
2295     dVAR; dSP; dTARGET;  tryAMAGICbin(scmp,0);
2296     {
2297       dPOPTOPssrl;
2298       const int cmp = (IN_LOCALE_RUNTIME
2299                  ? sv_cmp_locale(left, right)
2300                  : sv_cmp(left, right));
2301       SETi( cmp );
2302       RETURN;
2303     }
2304 }
2305
2306 PP(pp_bit_and)
2307 {
2308     dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2309     {
2310       dPOPTOPssrl;
2311       SvGETMAGIC(left);
2312       SvGETMAGIC(right);
2313       if (SvNIOKp(left) || SvNIOKp(right)) {
2314         if (PL_op->op_private & HINT_INTEGER) {
2315           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2316           SETi(i);
2317         }
2318         else {
2319           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2320           SETu(u);
2321         }
2322       }
2323       else {
2324         do_vop(PL_op->op_type, TARG, left, right);
2325         SETTARG;
2326       }
2327       RETURN;
2328     }
2329 }
2330
2331 PP(pp_bit_or)
2332 {
2333     dVAR; dSP; dATARGET;
2334     const int op_type = PL_op->op_type;
2335
2336     tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2337     {
2338       dPOPTOPssrl;
2339       SvGETMAGIC(left);
2340       SvGETMAGIC(right);
2341       if (SvNIOKp(left) || SvNIOKp(right)) {
2342         if (PL_op->op_private & HINT_INTEGER) {
2343           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2344           const IV r = SvIV_nomg(right);
2345           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2346           SETi(result);
2347         }
2348         else {
2349           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2350           const UV r = SvUV_nomg(right);
2351           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2352           SETu(result);
2353         }
2354       }
2355       else {
2356         do_vop(op_type, TARG, left, right);
2357         SETTARG;
2358       }
2359       RETURN;
2360     }
2361 }
2362
2363 PP(pp_negate)
2364 {
2365     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2366     {
2367         dTOPss;
2368         const int flags = SvFLAGS(sv);
2369         SvGETMAGIC(sv);
2370         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2371             /* It's publicly an integer, or privately an integer-not-float */
2372         oops_its_an_int:
2373             if (SvIsUV(sv)) {
2374                 if (SvIVX(sv) == IV_MIN) {
2375                     /* 2s complement assumption. */
2376                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2377                     RETURN;
2378                 }
2379                 else if (SvUVX(sv) <= IV_MAX) {
2380                     SETi(-SvIVX(sv));
2381                     RETURN;
2382                 }
2383             }
2384             else if (SvIVX(sv) != IV_MIN) {
2385                 SETi(-SvIVX(sv));
2386                 RETURN;
2387             }
2388 #ifdef PERL_PRESERVE_IVUV
2389             else {
2390                 SETu((UV)IV_MIN);
2391                 RETURN;
2392             }
2393 #endif
2394         }
2395         if (SvNIOKp(sv))
2396             SETn(-SvNV(sv));
2397         else if (SvPOKp(sv)) {
2398             STRLEN len;
2399             const char * const s = SvPV_const(sv, len);
2400             if (isIDFIRST(*s)) {
2401                 sv_setpvn(TARG, "-", 1);
2402                 sv_catsv(TARG, sv);
2403             }
2404             else if (*s == '+' || *s == '-') {
2405                 sv_setsv(TARG, sv);
2406                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2407             }
2408             else if (DO_UTF8(sv)) {
2409                 SvIV_please(sv);
2410                 if (SvIOK(sv))
2411                     goto oops_its_an_int;
2412                 if (SvNOK(sv))
2413                     sv_setnv(TARG, -SvNV(sv));
2414                 else {
2415                     sv_setpvn(TARG, "-", 1);
2416                     sv_catsv(TARG, sv);
2417                 }
2418             }
2419             else {
2420                 SvIV_please(sv);
2421                 if (SvIOK(sv))
2422                   goto oops_its_an_int;
2423                 sv_setnv(TARG, -SvNV(sv));
2424             }
2425             SETTARG;
2426         }
2427         else
2428             SETn(-SvNV(sv));
2429     }
2430     RETURN;
2431 }
2432
2433 PP(pp_not)
2434 {
2435     dVAR; dSP; tryAMAGICunSET(not);
2436     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2437     return NORMAL;
2438 }
2439
2440 PP(pp_complement)
2441 {
2442     dVAR; dSP; dTARGET; tryAMAGICun(compl);
2443     {
2444       dTOPss;
2445       SvGETMAGIC(sv);
2446       if (SvNIOKp(sv)) {
2447         if (PL_op->op_private & HINT_INTEGER) {
2448           const IV i = ~SvIV_nomg(sv);
2449           SETi(i);
2450         }
2451         else {
2452           const UV u = ~SvUV_nomg(sv);
2453           SETu(u);
2454         }
2455       }
2456       else {
2457         register U8 *tmps;
2458         register I32 anum;
2459         STRLEN len;
2460
2461         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2462         sv_setsv_nomg(TARG, sv);
2463         tmps = (U8*)SvPV_force(TARG, len);
2464         anum = len;
2465         if (SvUTF8(TARG)) {
2466           /* Calculate exact length, let's not estimate. */
2467           STRLEN targlen = 0;
2468           STRLEN l;
2469           UV nchar = 0;
2470           UV nwide = 0;
2471           U8 * const send = tmps + len;
2472           U8 * const origtmps = tmps;
2473           const UV utf8flags = UTF8_ALLOW_ANYUV;
2474
2475           while (tmps < send) {
2476             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2477             tmps += l;
2478             targlen += UNISKIP(~c);
2479             nchar++;
2480             if (c > 0xff)
2481                 nwide++;
2482           }
2483
2484           /* Now rewind strings and write them. */
2485           tmps = origtmps;
2486
2487           if (nwide) {
2488               U8 *result;
2489               U8 *p;
2490
2491               Newx(result, targlen + 1, U8);
2492               p = result;
2493               while (tmps < send) {
2494                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2495                   tmps += l;
2496                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2497               }
2498               *p = '\0';
2499               sv_usepvn_flags(TARG, (char*)result, targlen,
2500                               SV_HAS_TRAILING_NUL);
2501               SvUTF8_on(TARG);
2502           }
2503           else {
2504               U8 *result;
2505               U8 *p;
2506
2507               Newx(result, nchar + 1, U8);
2508               p = result;
2509               while (tmps < send) {
2510                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2511                   tmps += l;
2512                   *p++ = ~c;
2513               }
2514               *p = '\0';
2515               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2516               SvUTF8_off(TARG);
2517           }
2518           SETs(TARG);
2519           RETURN;
2520         }
2521 #ifdef LIBERAL
2522         {
2523             register long *tmpl;
2524             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2525                 *tmps = ~*tmps;
2526             tmpl = (long*)tmps;
2527             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2528                 *tmpl = ~*tmpl;
2529             tmps = (U8*)tmpl;
2530         }
2531 #endif
2532         for ( ; anum > 0; anum--, tmps++)
2533             *tmps = ~*tmps;
2534
2535         SETs(TARG);
2536       }
2537       RETURN;
2538     }
2539 }
2540
2541 /* integer versions of some of the above */
2542
2543 PP(pp_i_multiply)
2544 {
2545     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2546     {
2547       dPOPTOPiirl;
2548       SETi( left * right );
2549       RETURN;
2550     }
2551 }
2552
2553 PP(pp_i_divide)
2554 {
2555     IV num;
2556     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2557     {
2558       dPOPiv;
2559       if (value == 0)
2560           DIE(aTHX_ "Illegal division by zero");
2561       num = POPi;
2562
2563       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2564       if (value == -1)
2565           value = - num;
2566       else
2567           value = num / value;
2568       PUSHi( value );
2569       RETURN;
2570     }
2571 }
2572
2573 #if defined(__GLIBC__) && IVSIZE == 8
2574 STATIC
2575 PP(pp_i_modulo_0)
2576 #else
2577 PP(pp_i_modulo)
2578 #endif
2579 {
2580      /* This is the vanilla old i_modulo. */
2581      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2582      {
2583           dPOPTOPiirl;
2584           if (!right)
2585                DIE(aTHX_ "Illegal modulus zero");
2586           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2587           if (right == -1)
2588               SETi( 0 );
2589           else
2590               SETi( left % right );
2591           RETURN;
2592      }
2593 }
2594
2595 #if defined(__GLIBC__) && IVSIZE == 8
2596 STATIC
2597 PP(pp_i_modulo_1)
2598
2599 {
2600      /* This is the i_modulo with the workaround for the _moddi3 bug
2601       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2602       * See below for pp_i_modulo. */
2603      dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2604      {
2605           dPOPTOPiirl;
2606           if (!right)
2607                DIE(aTHX_ "Illegal modulus zero");
2608           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2609           if (right == -1)
2610               SETi( 0 );
2611           else
2612               SETi( left % PERL_ABS(right) );
2613           RETURN;
2614      }
2615 }
2616
2617 PP(pp_i_modulo)
2618 {
2619      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2620      {
2621           dPOPTOPiirl;
2622           if (!right)
2623                DIE(aTHX_ "Illegal modulus zero");
2624           /* The assumption is to use hereafter the old vanilla version... */
2625           PL_op->op_ppaddr =
2626                PL_ppaddr[OP_I_MODULO] =
2627                    Perl_pp_i_modulo_0;
2628           /* .. but if we have glibc, we might have a buggy _moddi3
2629            * (at least glicb 2.2.5 is known to have this bug), in other
2630            * words our integer modulus with negative quad as the second
2631            * argument might be broken.  Test for this and re-patch the
2632            * opcode dispatch table if that is the case, remembering to
2633            * also apply the workaround so that this first round works
2634            * right, too.  See [perl #9402] for more information. */
2635           {
2636                IV l =   3;
2637                IV r = -10;
2638                /* Cannot do this check with inlined IV constants since
2639                 * that seems to work correctly even with the buggy glibc. */
2640                if (l % r == -3) {
2641                     /* Yikes, we have the bug.
2642                      * Patch in the workaround version. */
2643                     PL_op->op_ppaddr =
2644                          PL_ppaddr[OP_I_MODULO] =
2645                              &Perl_pp_i_modulo_1;
2646                     /* Make certain we work right this time, too. */
2647                     right = PERL_ABS(right);
2648                }
2649           }
2650           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2651           if (right == -1)
2652               SETi( 0 );
2653           else
2654               SETi( left % right );
2655           RETURN;
2656      }
2657 }
2658 #endif
2659
2660 PP(pp_i_add)
2661 {
2662     dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2663     {
2664       dPOPTOPiirl_ul;
2665       SETi( left + right );
2666       RETURN;
2667     }
2668 }
2669
2670 PP(pp_i_subtract)
2671 {
2672     dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2673     {
2674       dPOPTOPiirl_ul;
2675       SETi( left - right );
2676       RETURN;
2677     }
2678 }
2679
2680 PP(pp_i_lt)
2681 {
2682     dVAR; dSP; tryAMAGICbinSET(lt,0);
2683     {
2684       dPOPTOPiirl;
2685       SETs(boolSV(left < right));
2686       RETURN;
2687     }
2688 }
2689
2690 PP(pp_i_gt)
2691 {
2692     dVAR; dSP; tryAMAGICbinSET(gt,0);
2693     {
2694       dPOPTOPiirl;
2695       SETs(boolSV(left > right));
2696       RETURN;
2697     }
2698 }
2699
2700 PP(pp_i_le)
2701 {
2702     dVAR; dSP; tryAMAGICbinSET(le,0);
2703     {
2704       dPOPTOPiirl;
2705       SETs(boolSV(left <= right));
2706       RETURN;
2707     }
2708 }
2709
2710 PP(pp_i_ge)
2711 {
2712     dVAR; dSP; tryAMAGICbinSET(ge,0);
2713     {
2714       dPOPTOPiirl;
2715       SETs(boolSV(left >= right));
2716       RETURN;
2717     }
2718 }
2719
2720 PP(pp_i_eq)
2721 {
2722     dVAR; dSP; tryAMAGICbinSET(eq,0);
2723     {
2724       dPOPTOPiirl;
2725       SETs(boolSV(left == right));
2726       RETURN;
2727     }
2728 }
2729
2730 PP(pp_i_ne)
2731 {
2732     dVAR; dSP; tryAMAGICbinSET(ne,0);
2733     {
2734       dPOPTOPiirl;
2735       SETs(boolSV(left != right));
2736       RETURN;
2737     }
2738 }
2739
2740 PP(pp_i_ncmp)
2741 {
2742     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2743     {
2744       dPOPTOPiirl;
2745       I32 value;
2746
2747       if (left > right)
2748         value = 1;
2749       else if (left < right)
2750         value = -1;
2751       else
2752         value = 0;
2753       SETi(value);
2754       RETURN;
2755     }
2756 }
2757
2758 PP(pp_i_negate)
2759 {
2760     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2761     SETi(-TOPi);
2762     RETURN;
2763 }
2764
2765 /* High falutin' math. */
2766
2767 PP(pp_atan2)
2768 {
2769     dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2770     {
2771       dPOPTOPnnrl;
2772       SETn(Perl_atan2(left, right));
2773       RETURN;
2774     }
2775 }
2776
2777 PP(pp_sin)
2778 {
2779     dVAR; dSP; dTARGET;
2780     int amg_type = sin_amg;
2781     const char *neg_report = NULL;
2782     NV (*func)(NV) = Perl_sin;
2783     const int op_type = PL_op->op_type;
2784
2785     switch (op_type) {
2786     case OP_COS:
2787         amg_type = cos_amg;
2788         func = Perl_cos;
2789         break;
2790     case OP_EXP:
2791         amg_type = exp_amg;
2792         func = Perl_exp;
2793         break;
2794     case OP_LOG:
2795         amg_type = log_amg;
2796         func = Perl_log;
2797         neg_report = "log";
2798         break;
2799     case OP_SQRT:
2800         amg_type = sqrt_amg;
2801         func = Perl_sqrt;
2802         neg_report = "sqrt";
2803         break;
2804     }
2805
2806     tryAMAGICun_var(amg_type);
2807     {
2808       const NV value = POPn;
2809       if (neg_report) {
2810           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2811               SET_NUMERIC_STANDARD();
2812               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2813           }
2814       }
2815       XPUSHn(func(value));
2816       RETURN;
2817     }
2818 }
2819
2820 /* Support Configure command-line overrides for rand() functions.
2821    After 5.005, perhaps we should replace this by Configure support
2822    for drand48(), random(), or rand().  For 5.005, though, maintain
2823    compatibility by calling rand() but allow the user to override it.
2824    See INSTALL for details.  --Andy Dougherty  15 July 1998
2825 */
2826 /* Now it's after 5.005, and Configure supports drand48() and random(),
2827    in addition to rand().  So the overrides should not be needed any more.
2828    --Jarkko Hietaniemi  27 September 1998
2829  */
2830
2831 #ifndef HAS_DRAND48_PROTO
2832 extern double drand48 (void);
2833 #endif
2834
2835 PP(pp_rand)
2836 {
2837     dVAR; dSP; dTARGET;
2838     NV value;
2839     if (MAXARG < 1)
2840         value = 1.0;
2841     else
2842         value = POPn;
2843     if (value == 0.0)
2844         value = 1.0;
2845     if (!PL_srand_called) {
2846         (void)seedDrand01((Rand_seed_t)seed());
2847         PL_srand_called = TRUE;
2848     }
2849     value *= Drand01();
2850     XPUSHn(value);
2851     RETURN;
2852 }
2853
2854 PP(pp_srand)
2855 {
2856     dVAR; dSP;
2857     const UV anum = (MAXARG < 1) ? seed() : POPu;
2858     (void)seedDrand01((Rand_seed_t)anum);
2859     PL_srand_called = TRUE;
2860     EXTEND(SP, 1);
2861     RETPUSHYES;
2862 }
2863
2864 PP(pp_int)
2865 {
2866     dVAR; dSP; dTARGET; tryAMAGICun(int);
2867     {
2868       const IV iv = TOPi; /* attempt to convert to IV if possible. */
2869       /* XXX it's arguable that compiler casting to IV might be subtly
2870          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2871          else preferring IV has introduced a subtle behaviour change bug. OTOH
2872          relying on floating point to be accurate is a bug.  */
2873
2874       if (!SvOK(TOPs))
2875         SETu(0);
2876       else if (SvIOK(TOPs)) {
2877         if (SvIsUV(TOPs)) {
2878             const UV uv = TOPu;
2879             SETu(uv);
2880         } else
2881             SETi(iv);
2882       } else {
2883           const NV value = TOPn;
2884           if (value >= 0.0) {
2885               if (value < (NV)UV_MAX + 0.5) {
2886                   SETu(U_V(value));
2887               } else {
2888                   SETn(Perl_floor(value));
2889               }
2890           }
2891           else {
2892               if (value > (NV)IV_MIN - 0.5) {
2893                   SETi(I_V(value));
2894               } else {
2895                   SETn(Perl_ceil(value));
2896               }
2897           }
2898       }
2899     }
2900     RETURN;
2901 }
2902
2903 PP(pp_abs)
2904 {
2905     dVAR; dSP; dTARGET; tryAMAGICun(abs);
2906     {
2907       /* This will cache the NV value if string isn't actually integer  */
2908       const IV iv = TOPi;
2909
2910       if (!SvOK(TOPs))
2911         SETu(0);
2912       else if (SvIOK(TOPs)) {
2913         /* IVX is precise  */
2914         if (SvIsUV(TOPs)) {
2915           SETu(TOPu);   /* force it to be numeric only */
2916         } else {
2917           if (iv >= 0) {
2918             SETi(iv);
2919           } else {
2920             if (iv != IV_MIN) {
2921               SETi(-iv);
2922             } else {
2923               /* 2s complement assumption. Also, not really needed as
2924                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2925               SETu(IV_MIN);
2926             }
2927           }
2928         }
2929       } else{
2930         const NV value = TOPn;
2931         if (value < 0.0)
2932           SETn(-value);
2933         else
2934           SETn(value);
2935       }
2936     }
2937     RETURN;
2938 }
2939
2940 PP(pp_oct)
2941 {
2942     dVAR; dSP; dTARGET;
2943     const char *tmps;
2944     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2945     STRLEN len;
2946     NV result_nv;
2947     UV result_uv;
2948     SV* const sv = POPs;
2949
2950     tmps = (SvPV_const(sv, len));
2951     if (DO_UTF8(sv)) {
2952          /* If Unicode, try to downgrade
2953           * If not possible, croak. */
2954          SV* const tsv = sv_2mortal(newSVsv(sv));
2955
2956          SvUTF8_on(tsv);
2957          sv_utf8_downgrade(tsv, FALSE);
2958          tmps = SvPV_const(tsv, len);
2959     }
2960     if (PL_op->op_type == OP_HEX)
2961         goto hex;
2962
2963     while (*tmps && len && isSPACE(*tmps))
2964         tmps++, len--;
2965     if (*tmps == '0')
2966         tmps++, len--;
2967     if (*tmps == 'x') {
2968     hex:
2969         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2970     }
2971     else if (*tmps == 'b')
2972         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2973     else
2974         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2975
2976     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2977         XPUSHn(result_nv);
2978     }
2979     else {
2980         XPUSHu(result_uv);
2981     }
2982     RETURN;
2983 }
2984
2985 /* String stuff. */
2986
2987 PP(pp_length)
2988 {
2989     dVAR; dSP; dTARGET;
2990     SV * const sv = TOPs;
2991
2992     if (SvAMAGIC(sv)) {
2993         /* For an overloaded scalar, we can't know in advance if it's going to
2994            be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2995            cache the length. Maybe that should be a documented feature of it.
2996         */
2997         STRLEN len;
2998         const char *const p = SvPV_const(sv, len);
2999
3000         if (DO_UTF8(sv)) {
3001             SETi(utf8_length((U8*)p, (U8*)p + len));
3002         }
3003         else
3004             SETi(len);
3005
3006     }
3007     else if (DO_UTF8(sv))
3008         SETi(sv_len_utf8(sv));
3009     else
3010         SETi(sv_len(sv));
3011     RETURN;
3012 }
3013
3014 PP(pp_substr)
3015 {
3016     dVAR; dSP; dTARGET;
3017     SV *sv;
3018     I32 len = 0;
3019     STRLEN curlen;
3020     STRLEN utf8_curlen;
3021     I32 pos;
3022     I32 rem;
3023     I32 fail;
3024     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3025     const char *tmps;
3026     const I32 arybase = CopARYBASE_get(PL_curcop);
3027     SV *repl_sv = NULL;
3028     const char *repl = NULL;
3029     STRLEN repl_len;
3030     const int num_args = PL_op->op_private & 7;
3031     bool repl_need_utf8_upgrade = FALSE;
3032     bool repl_is_utf8 = FALSE;
3033
3034     SvTAINTED_off(TARG);                        /* decontaminate */
3035     SvUTF8_off(TARG);                           /* decontaminate */
3036     if (num_args > 2) {
3037         if (num_args > 3) {
3038             repl_sv = POPs;
3039             repl = SvPV_const(repl_sv, repl_len);
3040             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3041         }
3042         len = POPi;
3043     }
3044     pos = POPi;
3045     sv = POPs;
3046     PUTBACK;
3047     if (repl_sv) {
3048         if (repl_is_utf8) {
3049             if (!DO_UTF8(sv))
3050                 sv_utf8_upgrade(sv);
3051         }
3052         else if (DO_UTF8(sv))
3053             repl_need_utf8_upgrade = TRUE;
3054     }
3055     tmps = SvPV_const(sv, curlen);
3056     if (DO_UTF8(sv)) {
3057         utf8_curlen = sv_len_utf8(sv);
3058         if (utf8_curlen == curlen)
3059             utf8_curlen = 0;
3060         else
3061             curlen = utf8_curlen;
3062     }
3063     else
3064         utf8_curlen = 0;
3065
3066     if (pos >= arybase) {
3067         pos -= arybase;
3068         rem = curlen-pos;
3069         fail = rem;
3070         if (num_args > 2) {
3071             if (len < 0) {
3072                 rem += len;
3073                 if (rem < 0)
3074                     rem = 0;
3075             }
3076             else if (rem > len)
3077                      rem = len;
3078         }
3079     }
3080     else {
3081         pos += curlen;
3082         if (num_args < 3)
3083             rem = curlen;
3084         else if (len >= 0) {
3085             rem = pos+len;
3086             if (rem > (I32)curlen)
3087                 rem = curlen;
3088         }
3089         else {
3090             rem = curlen+len;
3091             if (rem < pos)
3092                 rem = pos;
3093         }
3094         if (pos < 0)
3095             pos = 0;
3096         fail = rem;
3097         rem -= pos;
3098     }
3099     if (fail < 0) {
3100         if (lvalue || repl)
3101             Perl_croak(aTHX_ "substr outside of string");
3102         if (ckWARN(WARN_SUBSTR))
3103             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3104         RETPUSHUNDEF;
3105     }
3106     else {
3107         const I32 upos = pos;
3108         const I32 urem = rem;
3109         if (utf8_curlen)
3110             sv_pos_u2b(sv, &pos, &rem);
3111         tmps += pos;
3112         /* we either return a PV or an LV. If the TARG hasn't been used
3113          * before, or is of that type, reuse it; otherwise use a mortal
3114          * instead. Note that LVs can have an extended lifetime, so also
3115          * dont reuse if refcount > 1 (bug #20933) */
3116         if (SvTYPE(TARG) > SVt_NULL) {
3117             if ( (SvTYPE(TARG) == SVt_PVLV)
3118                     ? (!lvalue || SvREFCNT(TARG) > 1)
3119                     : lvalue)
3120             {
3121                 TARG = sv_newmortal();
3122             }
3123         }
3124
3125         sv_setpvn(TARG, tmps, rem);
3126 #ifdef USE_LOCALE_COLLATE
3127         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3128 #endif
3129         if (utf8_curlen)
3130             SvUTF8_on(TARG);
3131         if (repl) {
3132             SV* repl_sv_copy = NULL;
3133
3134             if (repl_need_utf8_upgrade) {
3135                 repl_sv_copy = newSVsv(repl_sv);
3136                 sv_utf8_upgrade(repl_sv_copy);
3137                 repl = SvPV_const(repl_sv_copy, repl_len);
3138                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3139             }
3140             sv_insert(sv, pos, rem, repl, repl_len);
3141             if (repl_is_utf8)
3142                 SvUTF8_on(sv);
3143             if (repl_sv_copy)
3144                 SvREFCNT_dec(repl_sv_copy);
3145         }
3146         else if (lvalue) {              /* it's an lvalue! */
3147             if (!SvGMAGICAL(sv)) {
3148                 if (SvROK(sv)) {
3149                     SvPV_force_nolen(sv);
3150                     if (ckWARN(WARN_SUBSTR))
3151                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3152                                 "Attempt to use reference as lvalue in substr");
3153                 }
3154                 if (isGV_with_GP(sv))
3155                     SvPV_force_nolen(sv);
3156                 else if (SvOK(sv))      /* is it defined ? */
3157                     (void)SvPOK_only_UTF8(sv);
3158                 else
3159                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3160             }
3161
3162             if (SvTYPE(TARG) < SVt_PVLV) {
3163                 sv_upgrade(TARG, SVt_PVLV);
3164                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3165             }
3166
3167             LvTYPE(TARG) = 'x';
3168             if (LvTARG(TARG) != sv) {
3169                 if (LvTARG(TARG))
3170                     SvREFCNT_dec(LvTARG(TARG));
3171                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3172             }
3173             LvTARGOFF(TARG) = upos;
3174             LvTARGLEN(TARG) = urem;
3175         }
3176     }
3177     SPAGAIN;
3178     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3179     RETURN;
3180 }
3181
3182 PP(pp_vec)
3183 {
3184     dVAR; dSP; dTARGET;
3185     register const IV size   = POPi;
3186     register const IV offset = POPi;
3187     register SV * const src = POPs;
3188     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3189
3190     SvTAINTED_off(TARG);                /* decontaminate */
3191     if (lvalue) {                       /* it's an lvalue! */
3192         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3193             TARG = sv_newmortal();
3194         if (SvTYPE(TARG) < SVt_PVLV) {
3195             sv_upgrade(TARG, SVt_PVLV);
3196             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3197         }
3198         LvTYPE(TARG) = 'v';
3199         if (LvTARG(TARG) != src) {
3200             if (LvTARG(TARG))
3201                 SvREFCNT_dec(LvTARG(TARG));
3202             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3203         }
3204         LvTARGOFF(TARG) = offset;
3205         LvTARGLEN(TARG) = size;
3206     }
3207
3208     sv_setuv(TARG, do_vecget(src, offset, size));
3209     PUSHs(TARG);
3210     RETURN;
3211 }
3212
3213 PP(pp_index)
3214 {
3215     dVAR; dSP; dTARGET;
3216     SV *big;
3217     SV *little;
3218     SV *temp = NULL;
3219     STRLEN biglen;
3220     STRLEN llen = 0;
3221     I32 offset;
3222     I32 retval;
3223     const char *big_p;
3224     const char *little_p;
3225     const I32 arybase = CopARYBASE_get(PL_curcop);
3226     bool big_utf8;
3227     bool little_utf8;
3228     const bool is_index = PL_op->op_type == OP_INDEX;
3229
3230     if (MAXARG >= 3) {
3231         /* arybase is in characters, like offset, so combine prior to the
3232            UTF-8 to bytes calculation.  */
3233         offset = POPi - arybase;
3234     }
3235     little = POPs;
3236     big = POPs;
3237     big_p = SvPV_const(big, biglen);
3238     little_p = SvPV_const(little, llen);
3239
3240     big_utf8 = DO_UTF8(big);
3241     little_utf8 = DO_UTF8(little);
3242     if (big_utf8 ^ little_utf8) {
3243         /* One needs to be upgraded.  */
3244         if (little_utf8 && !PL_encoding) {
3245             /* Well, maybe instead we might be able to downgrade the small
3246                string?  */
3247             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3248                                                      &little_utf8);
3249             if (little_utf8) {
3250                 /* If the large string is ISO-8859-1, and it's not possible to
3251                    convert the small string to ISO-8859-1, then there is no
3252                    way that it could be found anywhere by index.  */
3253                 retval = -1;
3254                 goto fail;
3255             }
3256
3257             /* At this point, pv is a malloc()ed string. So donate it to temp
3258                to ensure it will get free()d  */
3259             little = temp = newSV(0);
3260             sv_usepvn(temp, pv, llen);
3261             little_p = SvPVX(little);
3262         } else {
3263             temp = little_utf8
3264                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3265
3266             if (PL_encoding) {
3267                 sv_recode_to_utf8(temp, PL_encoding);
3268             } else {
3269                 sv_utf8_upgrade(temp);
3270             }
3271             if (little_utf8) {
3272                 big = temp;
3273                 big_utf8 = TRUE;
3274                 big_p = SvPV_const(big, biglen);
3275             } else {
3276                 little = temp;
3277                 little_p = SvPV_const(little, llen);
3278             }
3279         }
3280     }
3281     if (SvGAMAGIC(big)) {
3282         /* Life just becomes a lot easier if I use a temporary here.
3283            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3284            will trigger magic and overloading again, as will fbm_instr()
3285         */
3286         big = sv_2mortal(newSVpvn(big_p, biglen));
3287         if (big_utf8)
3288             SvUTF8_on(big);
3289         big_p = SvPVX(big);
3290     }
3291     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3292         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3293            warn on undef, and we've already triggered a warning with the
3294            SvPV_const some lines above. We can't remove that, as we need to
3295            call some SvPV to trigger overloading early and find out if the
3296            string is UTF-8.
3297            This is all getting to messy. The API isn't quite clean enough,
3298            because data access has side effects.
3299         */
3300         little = sv_2mortal(newSVpvn(little_p, llen));
3301         if (little_utf8)
3302             SvUTF8_on(little);
3303         little_p = SvPVX(little);
3304     }
3305
3306     if (MAXARG < 3)
3307         offset = is_index ? 0 : biglen;
3308     else {
3309         if (big_utf8 && offset > 0)
3310             sv_pos_u2b(big, &offset, 0);
3311         if (!is_index)
3312             offset += llen;
3313     }
3314     if (offset < 0)
3315         offset = 0;
3316     else if (offset > (I32)biglen)
3317         offset = biglen;
3318     if (!(little_p = is_index
3319           ? fbm_instr((unsigned char*)big_p + offset,
3320                       (unsigned char*)big_p + biglen, little, 0)
3321           : rninstr(big_p,  big_p  + offset,
3322                     little_p, little_p + llen)))
3323         retval = -1;
3324     else {
3325         retval = little_p - big_p;
3326         if (retval > 0 && big_utf8)
3327             sv_pos_b2u(big, &retval);
3328     }
3329     if (temp)
3330         SvREFCNT_dec(temp);
3331  fail:
3332     PUSHi(retval + arybase);
3333     RETURN;
3334 }
3335
3336 PP(pp_sprintf)
3337 {
3338     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3339     if (SvTAINTED(MARK[1]))
3340         TAINT_PROPER("sprintf");
3341     do_sprintf(TARG, SP-MARK, MARK+1);
3342     TAINT_IF(SvTAINTED(TARG));
3343     SP = ORIGMARK;
3344     PUSHTARG;
3345     RETURN;
3346 }
3347
3348 PP(pp_ord)
3349 {
3350     dVAR; dSP; dTARGET;
3351
3352     SV *argsv = POPs;
3353     STRLEN len;
3354     const U8 *s = (U8*)SvPV_const(argsv, len);
3355
3356     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3357         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3358         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3359         argsv = tmpsv;
3360     }
3361
3362     XPUSHu(DO_UTF8(argsv) ?
3363            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3364            (UV)(*s & 0xff));
3365
3366     RETURN;
3367 }
3368
3369 PP(pp_chr)
3370 {
3371     dVAR; dSP; dTARGET;
3372     char *tmps;
3373     UV value;
3374
3375     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3376          ||
3377          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3378         if (IN_BYTES) {
3379             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3380         } else {
3381             (void) POPs; /* Ignore the argument value. */
3382             value = UNICODE_REPLACEMENT;
3383         }
3384     } else {
3385         value = POPu;
3386     }
3387
3388     SvUPGRADE(TARG,SVt_PV);
3389
3390     if (value > 255 && !IN_BYTES) {
3391         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3392         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3393         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3394         *tmps = '\0';
3395         (void)SvPOK_only(TARG);
3396         SvUTF8_on(TARG);
3397         XPUSHs(TARG);
3398         RETURN;
3399     }
3400
3401     SvGROW(TARG,2);
3402     SvCUR_set(TARG, 1);
3403     tmps = SvPVX(TARG);
3404     *tmps++ = (char)value;
3405     *tmps = '\0';
3406     (void)SvPOK_only(TARG);
3407
3408     if (PL_encoding && !IN_BYTES) {
3409         sv_recode_to_utf8(TARG, PL_encoding);
3410         tmps = SvPVX(TARG);
3411         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3412             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3413             SvGROW(TARG, 2);
3414             tmps = SvPVX(TARG);
3415             SvCUR_set(TARG, 1);
3416             *tmps++ = (char)value;
3417             *tmps = '\0';
3418             SvUTF8_off(TARG);
3419         }
3420     }
3421
3422     XPUSHs(TARG);
3423     RETURN;
3424 }
3425
3426 PP(pp_crypt)
3427 {
3428 #ifdef HAS_CRYPT
3429     dVAR; dSP; dTARGET;
3430     dPOPTOPssrl;
3431     STRLEN len;
3432     const char *tmps = SvPV_const(left, len);
3433
3434     if (DO_UTF8(left)) {
3435          /* If Unicode, try to downgrade.
3436           * If not possible, croak.
3437           * Yes, we made this up.  */
3438          SV* const tsv = sv_2mortal(newSVsv(left));
3439
3440          SvUTF8_on(tsv);
3441          sv_utf8_downgrade(tsv, FALSE);
3442          tmps = SvPV_const(tsv, len);
3443     }
3444 #   ifdef USE_ITHREADS
3445 #     ifdef HAS_CRYPT_R
3446     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3447       /* This should be threadsafe because in ithreads there is only
3448        * one thread per interpreter.  If this would not be true,
3449        * we would need a mutex to protect this malloc. */
3450         PL_reentrant_buffer->_crypt_struct_buffer =
3451           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3452 #if defined(__GLIBC__) || defined(__EMX__)
3453         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3454             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3455             /* work around glibc-2.2.5 bug */
3456             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3457         }
3458 #endif
3459     }
3460 #     endif /* HAS_CRYPT_R */
3461 #   endif /* USE_ITHREADS */
3462 #   ifdef FCRYPT
3463     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3464 #   else
3465     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3466 #   endif
3467     SETs(TARG);
3468     RETURN;
3469 #else
3470     DIE(aTHX_
3471       "The crypt() function is unimplemented due to excessive paranoia.");
3472 #endif
3473 }
3474
3475 PP(pp_ucfirst)
3476 {
3477     dVAR;
3478     dSP;
3479     SV *source = TOPs;
3480     STRLEN slen;
3481     STRLEN need;
3482     SV *dest;
3483     bool inplace = TRUE;
3484     bool doing_utf8;
3485     const int op_type = PL_op->op_type;
3486     const U8 *s;
3487     U8 *d;
3488     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3489     STRLEN ulen;
3490     STRLEN tculen;
3491
3492     SvGETMAGIC(source);
3493     if (SvOK(source)) {
3494         s = (const U8*)SvPV_nomg_const(source, slen);
3495     } else {
3496         s = (const U8*)"";
3497         slen = 0;
3498     }
3499
3500     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3501         doing_utf8 = TRUE;
3502         utf8_to_uvchr(s, &ulen);
3503         if (op_type == OP_UCFIRST) {
3504             toTITLE_utf8(s, tmpbuf, &tculen);
3505         } else {
3506             toLOWER_utf8(s, tmpbuf, &tculen);
3507         }
3508         /* If the two differ, we definately cannot do inplace.  */
3509         inplace = (ulen == tculen);
3510         need = slen + 1 - ulen + tculen;
3511     } else {
3512         doing_utf8 = FALSE;
3513         need = slen + 1;
3514     }
3515
3516     if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3517         /* We can convert in place.  */
3518
3519         dest = source;
3520         s = d = (U8*)SvPV_force_nomg(source, slen);
3521     } else {
3522         dTARGET;
3523
3524         dest = TARG;
3525
3526         SvUPGRADE(dest, SVt_PV);
3527         d = (U8*)SvGROW(dest, need);
3528         (void)SvPOK_only(dest);
3529
3530         SETs(dest);
3531
3532         inplace = FALSE;
3533     }
3534
3535     if (doing_utf8) {
3536         if(!inplace) {
3537             /* slen is the byte length of the whole SV.
3538              * ulen is the byte length of the original Unicode character
3539              * stored as UTF-8 at s.
3540              * tculen is the byte length of the freshly titlecased (or
3541              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3542              * We first set the result to be the titlecased (/lowercased)
3543              * character, and then append the rest of the SV data. */
3544             sv_setpvn(dest, (char*)tmpbuf, tculen);
3545             if (slen > ulen)
3546                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3547             SvUTF8_on(dest);
3548         }
3549         else {
3550             Copy(tmpbuf, d, tculen, U8);
3551             SvCUR_set(dest, need - 1);
3552         }
3553     }
3554     else {
3555         if (*s) {
3556             if (IN_LOCALE_RUNTIME) {
3557                 TAINT;
3558                 SvTAINTED_on(dest);
3559                 *d = (op_type == OP_UCFIRST)
3560                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3561             }
3562             else
3563                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3564         } else {
3565             /* See bug #39028  */
3566             *d = *s;
3567         }
3568
3569         if (SvUTF8(source))
3570             SvUTF8_on(dest);
3571
3572         if (!inplace) {
3573             /* This will copy the trailing NUL  */
3574             Copy(s + 1, d + 1, slen, U8);
3575             SvCUR_set(dest, need - 1);
3576         }
3577     }
3578     SvSETMAGIC(dest);
3579     RETURN;
3580 }
3581
3582 /* There's so much setup/teardown code common between uc and lc, I wonder if
3583    it would be worth merging the two, and just having a switch outside each
3584    of the three tight loops.  */
3585 PP(pp_uc)
3586 {
3587     dVAR;
3588     dSP;
3589     SV *source = TOPs;
3590     STRLEN len;
3591     STRLEN min;
3592     SV *dest;
3593     const U8 *s;
3594     U8 *d;
3595
3596     SvGETMAGIC(source);
3597
3598     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3599         && !DO_UTF8(source)) {
3600         /* We can convert in place.  */
3601
3602         dest = source;
3603         s = d = (U8*)SvPV_force_nomg(source, len);
3604         min = len + 1;
3605     } else {
3606         dTARGET;
3607
3608         dest = TARG;
3609
3610         /* The old implementation would copy source into TARG at this point.
3611            This had the side effect that if source was undef, TARG was now
3612            an undefined SV with PADTMP set, and they don't warn inside
3613            sv_2pv_flags(). However, we're now getting the PV direct from
3614            source, which doesn't have PADTMP set, so it would warn. Hence the
3615            little games.  */
3616
3617         if (SvOK(source)) {
3618             s = (const U8*)SvPV_nomg_const(source, len);
3619         } else {
3620             s = (const U8*)"";
3621             len = 0;
3622         }
3623         min = len + 1;
3624
3625         SvUPGRADE(dest, SVt_PV);
3626         d = (U8*)SvGROW(dest, min);
3627         (void)SvPOK_only(dest);
3628
3629         SETs(dest);
3630     }
3631
3632     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3633        to check DO_UTF8 again here.  */
3634
3635     if (DO_UTF8(source)) {
3636         const U8 *const send = s + len;
3637         U8 tmpbuf[UTF8_MAXBYTES+1];
3638
3639         while (s < send) {
3640             const STRLEN u = UTF8SKIP(s);
3641             STRLEN ulen;
3642
3643             toUPPER_utf8(s, tmpbuf, &ulen);
3644             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3645                 /* If the eventually required minimum size outgrows
3646                  * the available space, we need to grow. */
3647                 const UV o = d - (U8*)SvPVX_const(dest);
3648
3649                 /* If someone uppercases one million U+03B0s we SvGROW() one
3650                  * million times.  Or we could try guessing how much to
3651                  allocate without allocating too much.  Such is life. */
3652                 SvGROW(dest, min);
3653                 d = (U8*)SvPVX(dest) + o;
3654             }
3655             Copy(tmpbuf, d, ulen, U8);
3656             d += ulen;
3657             s += u;
3658         }
3659         SvUTF8_on(dest);
3660         *d = '\0';
3661         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3662     } else {
3663         if (len) {
3664             const U8 *const send = s + len;
3665             if (IN_LOCALE_RUNTIME) {
3666                 TAINT;
3667                 SvTAINTED_on(dest);
3668                 for (; s < send; d++, s++)
3669                     *d = toUPPER_LC(*s);
3670             }
3671             else {
3672                 for (; s < send; d++, s++)
3673                     *d = toUPPER(*s);
3674             }
3675         }
3676         if (source != dest) {
3677             *d = '\0';
3678             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3679         }
3680     }
3681     SvSETMAGIC(dest);
3682     RETURN;
3683 }
3684
3685 PP(pp_lc)
3686 {
3687     dVAR;
3688     dSP;
3689     SV *source = TOPs;
3690     STRLEN len;
3691     STRLEN min;
3692     SV *dest;
3693     const U8 *s;
3694     U8 *d;
3695
3696     SvGETMAGIC(source);
3697
3698     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3699         && !DO_UTF8(source)) {
3700         /* We can convert in place.  */
3701
3702         dest = source;
3703         s = d = (U8*)SvPV_force_nomg(source, len);
3704         min = len + 1;
3705     } else {
3706         dTARGET;
3707
3708         dest = TARG;
3709
3710         /* The old implementation would copy source into TARG at this point.
3711            This had the side effect that if source was undef, TARG was now
3712            an undefined SV with PADTMP set, and they don't warn inside
3713            sv_2pv_flags(). However, we're now getting the PV direct from
3714            source, which doesn't have PADTMP set, so it would warn. Hence the
3715            little games.  */
3716
3717         if (SvOK(source)) {
3718             s = (const U8*)SvPV_nomg_const(source, len);
3719         } else {
3720             s = (const U8*)"";
3721             len = 0;
3722         }
3723         min = len + 1;
3724
3725         SvUPGRADE(dest, SVt_PV);
3726         d = (U8*)SvGROW(dest, min);
3727         (void)SvPOK_only(dest);
3728
3729         SETs(dest);
3730     }
3731
3732     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3733        to check DO_UTF8 again here.  */
3734
3735     if (DO_UTF8(source)) {
3736         const U8 *const send = s + len;
3737         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3738
3739         while (s < send) {
3740             const STRLEN u = UTF8SKIP(s);
3741             STRLEN ulen;
3742             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3743
3744 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3745             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3746                 NOOP;
3747                 /*
3748                  * Now if the sigma is NOT followed by
3749                  * /$ignorable_sequence$cased_letter/;
3750                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3751                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3752                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3753                  * then it should be mapped to 0x03C2,
3754                  * (GREEK SMALL LETTER FINAL SIGMA),
3755                  * instead of staying 0x03A3.
3756                  * "should be": in other words, this is not implemented yet.
3757                  * See lib/unicore/SpecialCasing.txt.
3758                  */
3759             }
3760             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3761                 /* If the eventually required minimum size outgrows
3762                  * the available space, we need to grow. */
3763                 const UV o = d - (U8*)SvPVX_const(dest);
3764
3765                 /* If someone lowercases one million U+0130s we SvGROW() one
3766                  * million times.  Or we could try guessing how much to
3767                  allocate without allocating too much.  Such is life. */
3768                 SvGROW(dest, min);
3769                 d = (U8*)SvPVX(dest) + o;
3770             }
3771             Copy(tmpbuf, d, ulen, U8);
3772             d += ulen;
3773             s += u;
3774         }
3775         SvUTF8_on(dest);
3776         *d = '\0';
3777         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3778     } else {
3779         if (len) {
3780             const U8 *const send = s + len;
3781             if (IN_LOCALE_RUNTIME) {
3782                 TAINT;
3783                 SvTAINTED_on(dest);
3784                 for (; s < send; d++, s++)
3785                     *d = toLOWER_LC(*s);
3786             }
3787             else {
3788                 for (; s < send; d++, s++)
3789                     *d = toLOWER(*s);
3790             }
3791         }
3792         if (source != dest) {
3793             *d = '\0';
3794             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3795         }
3796     }
3797     SvSETMAGIC(dest);
3798     RETURN;
3799 }
3800
3801 PP(pp_quotemeta)
3802 {
3803     dVAR; dSP; dTARGET;
3804     SV * const sv = TOPs;
3805     STRLEN len;
3806     register const char *s = SvPV_const(sv,len);
3807
3808     SvUTF8_off(TARG);                           /* decontaminate */
3809     if (len) {
3810         register char *d;
3811         SvUPGRADE(TARG, SVt_PV);
3812         SvGROW(TARG, (len * 2) + 1);
3813         d = SvPVX(TARG);
3814         if (DO_UTF8(sv)) {
3815             while (len) {
3816                 if (UTF8_IS_CONTINUED(*s)) {
3817                     STRLEN ulen = UTF8SKIP(s);
3818                     if (ulen > len)
3819                         ulen = len;
3820                     len -= ulen;
3821                     while (ulen--)
3822                         *d++ = *s++;
3823                 }
3824                 else {
3825                     if (!isALNUM(*s))
3826                         *d++ = '\\';
3827                     *d++ = *s++;
3828                     len--;
3829                 }
3830             }
3831             SvUTF8_on(TARG);
3832         }
3833         else {
3834             while (len--) {
3835                 if (!isALNUM(*s))
3836                     *d++ = '\\';
3837                 *d++ = *s++;
3838             }
3839         }
3840         *d = '\0';
3841         SvCUR_set(TARG, d - SvPVX_const(TARG));
3842         (void)SvPOK_only_UTF8(TARG);
3843     }
3844     else
3845         sv_setpvn(TARG, s, len);
3846     SETs(TARG);
3847     if (SvSMAGICAL(TARG))
3848         mg_set(TARG);
3849     RETURN;
3850 }
3851
3852 /* Arrays. */
3853
3854 PP(pp_aslice)
3855 {
3856     dVAR; dSP; dMARK; dORIGMARK;
3857     register AV* const av = (AV*)POPs;
3858     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3859
3860     if (SvTYPE(av) == SVt_PVAV) {
3861         const I32 arybase = CopARYBASE_get(PL_curcop);
3862         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3863             register SV **svp;
3864             I32 max = -1;
3865             for (svp = MARK + 1; svp <= SP; svp++) {
3866                 const I32 elem = SvIV(*svp);
3867                 if (elem > max)
3868                     max = elem;
3869             }
3870             if (max > AvMAX(av))
3871                 av_extend(av, max);
3872         }
3873         while (++MARK <= SP) {
3874             register SV **svp;
3875             I32 elem = SvIV(*MARK);
3876
3877             if (elem > 0)
3878                 elem -= arybase;
3879             svp = av_fetch(av, elem, lval);
3880             if (lval) {
3881                 if (!svp || *svp == &PL_sv_undef)
3882                     DIE(aTHX_ PL_no_aelem, elem);
3883                 if (PL_op->op_private & OPpLVAL_INTRO)
3884                     save_aelem(av, elem, svp);
3885             }
3886             *MARK = svp ? *svp : &PL_sv_undef;
3887         }
3888     }
3889     if (GIMME != G_ARRAY) {
3890         MARK = ORIGMARK;
3891         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3892         SP = MARK;
3893     }
3894     RETURN;
3895 }
3896
3897 /* Associative arrays. */
3898
3899 PP(pp_each)
3900 {
3901     dVAR;
3902     dSP;
3903     HV * hash = (HV*)POPs;
3904     HE *entry;
3905     const I32 gimme = GIMME_V;
3906
3907     PUTBACK;
3908     /* might clobber stack_sp */
3909     entry = hv_iternext(hash);
3910     SPAGAIN;
3911
3912     EXTEND(SP, 2);
3913     if (entry) {
3914         SV* const sv = hv_iterkeysv(entry);
3915         PUSHs(sv);      /* won't clobber stack_sp */
3916         if (gimme == G_ARRAY) {
3917             SV *val;
3918             PUTBACK;
3919             /* might clobber stack_sp */
3920             val = hv_iterval(hash, entry);
3921             SPAGAIN;
3922             PUSHs(val);
3923         }
3924     }
3925     else if (gimme == G_SCALAR)
3926         RETPUSHUNDEF;
3927
3928     RETURN;
3929 }
3930
3931 PP(pp_delete)
3932 {
3933     dVAR;
3934     dSP;
3935     const I32 gimme = GIMME_V;
3936     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3937
3938     if (PL_op->op_private & OPpSLICE) {
3939         dMARK; dORIGMARK;
3940         HV * const hv = (HV*)POPs;
3941         const U32 hvtype = SvTYPE(hv);
3942         if (hvtype == SVt_PVHV) {                       /* hash element */
3943             while (++MARK <= SP) {
3944                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3945                 *MARK = sv ? sv : &PL_sv_undef;
3946             }
3947         }
3948         else if (hvtype == SVt_PVAV) {                  /* array element */
3949             if (PL_op->op_flags & OPf_SPECIAL) {
3950                 while (++MARK <= SP) {
3951                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3952                     *MARK = sv ? sv : &PL_sv_undef;
3953                 }
3954             }
3955         }
3956         else
3957             DIE(aTHX_ "Not a HASH reference");
3958         if (discard)
3959             SP = ORIGMARK;
3960         else if (gimme == G_SCALAR) {
3961             MARK = ORIGMARK;
3962             if (SP > MARK)
3963                 *++MARK = *SP;
3964             else
3965                 *++MARK = &PL_sv_undef;
3966             SP = MARK;
3967         }
3968     }
3969     else {
3970         SV *keysv = POPs;
3971         HV * const hv = (HV*)POPs;
3972         SV *sv;
3973         if (SvTYPE(hv) == SVt_PVHV)
3974             sv = hv_delete_ent(hv, keysv, discard, 0);
3975         else if (SvTYPE(hv) == SVt_PVAV) {
3976             if (PL_op->op_flags & OPf_SPECIAL)
3977                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3978             else
3979                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3980         }
3981         else
3982             DIE(aTHX_ "Not a HASH reference");
3983         if (!sv)
3984             sv = &PL_sv_undef;
3985         if (!discard)
3986             PUSHs(sv);
3987     }
3988     RETURN;
3989 }
3990
3991 PP(pp_exists)
3992 {
3993     dVAR;
3994     dSP;
3995     SV *tmpsv;
3996     HV *hv;
3997
3998     if (PL_op->op_private & OPpEXISTS_SUB) {
3999         GV *gv;
4000         SV * const sv = POPs;
4001         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4002         if (cv)
4003             RETPUSHYES;
4004         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4005             RETPUSHYES;
4006         RETPUSHNO;
4007     }
4008     tmpsv = POPs;
4009     hv = (HV*)POPs;
4010     if (SvTYPE(hv) == SVt_PVHV) {
4011         if (hv_exists_ent(hv, tmpsv, 0))
4012             RETPUSHYES;
4013     }
4014     else if (SvTYPE(hv) == SVt_PVAV) {
4015         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4016             if (av_exists((AV*)hv, SvIV(tmpsv)))
4017                 RETPUSHYES;
4018         }
4019     }
4020     else {
4021         DIE(aTHX_ "Not a HASH reference");
4022     }
4023     RETPUSHNO;
4024 }
4025
4026 PP(pp_hslice)
4027 {
4028     dVAR; dSP; dMARK; dORIGMARK;
4029     register HV * const hv = (HV*)POPs;
4030     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4031     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4032     bool other_magic = FALSE;
4033
4034     if (localizing) {
4035         MAGIC *mg;
4036         HV *stash;
4037
4038         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4039             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4040              /* Try to preserve the existenceness of a tied hash
4041               * element by using EXISTS and DELETE if possible.
4042               * Fallback to FETCH and STORE otherwise */
4043              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4044              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4045              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4046     }
4047
4048     while (++MARK <= SP) {
4049         SV * const keysv = *MARK;
4050         SV **svp;
4051         HE *he;
4052         bool preeminent = FALSE;
4053
4054         if (localizing) {
4055             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4056                 hv_exists_ent(hv, keysv, 0);
4057         }
4058
4059         he = hv_fetch_ent(hv, keysv, lval, 0);
4060         svp = he ? &HeVAL(he) : 0;
4061
4062         if (lval) {
4063             if (!svp || *svp == &PL_sv_undef) {
4064                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4065             }
4066             if (localizing) {
4067                 if (HvNAME_get(hv) && isGV(*svp))
4068                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4069                 else {
4070                     if (preeminent)
4071                         save_helem(hv, keysv, svp);
4072                     else {
4073                         STRLEN keylen;
4074                         const char * const key = SvPV_const(keysv, keylen);
4075                         SAVEDELETE(hv, savepvn(key,keylen),
4076                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4077                     }
4078                 }
4079             }
4080         }
4081         *MARK = svp ? *svp : &PL_sv_undef;
4082     }
4083     if (GIMME != G_ARRAY) {
4084         MARK = ORIGMARK;
4085         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4086         SP = MARK;
4087     }
4088     RETURN;
4089 }
4090
4091 /* List operators. */
4092
4093 PP(pp_list)
4094 {
4095     dVAR; dSP; dMARK;
4096     if (GIMME != G_ARRAY) {
4097         if (++MARK <= SP)
4098             *MARK = *SP;                /* unwanted list, return last item */
4099         else
4100             *MARK = &PL_sv_undef;
4101         SP = MARK;
4102     }
4103     RETURN;
4104 }
4105
4106 PP(pp_lslice)
4107 {
4108     dVAR;
4109     dSP;
4110     SV ** const lastrelem = PL_stack_sp;
4111     SV ** const lastlelem = PL_stack_base + POPMARK;
4112     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4113     register SV ** const firstrelem = lastlelem + 1;
4114     const I32 arybase = CopARYBASE_get(PL_curcop);
4115     I32 is_something_there = FALSE;
4116
4117     register const I32 max = lastrelem - lastlelem;
4118     register SV **lelem;
4119
4120     if (GIMME != G_ARRAY) {
4121         I32 ix = SvIV(*lastlelem);
4122         if (ix < 0)
4123             ix += max;
4124         else
4125             ix -= arybase;
4126         if (ix < 0 || ix >= max)
4127             *firstlelem = &PL_sv_undef;
4128         else
4129             *firstlelem = firstrelem[ix];
4130         SP = firstlelem;
4131         RETURN;
4132     }
4133
4134     if (max == 0) {
4135         SP = firstlelem - 1;
4136         RETURN;
4137     }
4138
4139     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4140         I32 ix = SvIV(*lelem);
4141         if (ix < 0)
4142             ix += max;
4143         else
4144             ix -= arybase;
4145         if (ix < 0 || ix >= max)
4146             *lelem = &PL_sv_undef;
4147         else {
4148             is_something_there = TRUE;
4149             if (!(*lelem = firstrelem[ix]))
4150                 *lelem = &PL_sv_undef;
4151         }
4152     }
4153     if (is_something_there)
4154         SP = lastlelem;
4155     else
4156         SP = firstlelem - 1;
4157     RETURN;
4158 }
4159
4160 PP(pp_anonlist)
4161 {
4162     dVAR; dSP; dMARK; dORIGMARK;
4163     const I32 items = SP - MARK;
4164     SV * const av = (SV *) av_make(items, MARK+1);
4165     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4166     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4167                       ? newRV_noinc(av) : av));
4168     RETURN;
4169 }
4170
4171 PP(pp_anonhash)
4172 {
4173     dVAR; dSP; dMARK; dORIGMARK;
4174     HV* const hv = newHV();
4175
4176     while (MARK < SP) {
4177         SV * const key = *++MARK;
4178         SV * const val = newSV(0);
4179         if (MARK < SP)
4180             sv_setsv(val, *++MARK);
4181         else if (ckWARN(WARN_MISC))
4182             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4183         (void)hv_store_ent(hv,key,val,0);
4184     }
4185     SP = ORIGMARK;
4186     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4187                       ? newRV_noinc((SV*) hv) : (SV*)hv));
4188     RETURN;
4189 }
4190
4191 PP(pp_splice)
4192 {
4193     dVAR; dSP; dMARK; dORIGMARK;
4194     register AV *ary = (AV*)*++MARK;
4195     register SV **src;
4196     register SV **dst;
4197     register I32 i;
4198     register I32 offset;
4199     register I32 length;
4200     I32 newlen;
4201     I32 after;
4202     I32 diff;
4203     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4204
4205     if (mg) {
4206         *MARK-- = SvTIED_obj((SV*)ary, mg);
4207         PUSHMARK(MARK);
4208         PUTBACK;
4209         ENTER;
4210         call_method("SPLICE",GIMME_V);
4211         LEAVE;
4212         SPAGAIN;
4213         RETURN;
4214     }
4215
4216     SP++;
4217
4218     if (++MARK < SP) {
4219         offset = i = SvIV(*MARK);
4220         if (offset < 0)
4221             offset += AvFILLp(ary) + 1;
4222         else
4223             offset -= CopARYBASE_get(PL_curcop);
4224         if (offset < 0)
4225             DIE(aTHX_ PL_no_aelem, i);
4226         if (++MARK < SP) {
4227             length = SvIVx(*MARK++);
4228             if (length < 0) {
4229                 length += AvFILLp(ary) - offset + 1;
4230                 if (length < 0)
4231                     length = 0;
4232             }
4233         }
4234         else
4235             length = AvMAX(ary) + 1;            /* close enough to infinity */
4236     }
4237     else {
4238         offset = 0;
4239         length = AvMAX(ary) + 1;
4240     }
4241     if (offset > AvFILLp(ary) + 1) {
4242         if (ckWARN(WARN_MISC))
4243             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4244         offset = AvFILLp(ary) + 1;
4245     }
4246     after = AvFILLp(ary) + 1 - (offset + length);
4247     if (after < 0) {                            /* not that much array */
4248         length += after;                        /* offset+length now in array */
4249         after = 0;
4250         if (!AvALLOC(ary))
4251             av_extend(ary, 0);
4252     }
4253
4254     /* At this point, MARK .. SP-1 is our new LIST */
4255
4256     newlen = SP - MARK;
4257     diff = newlen - length;
4258     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4259         av_reify(ary);
4260
4261     /* make new elements SVs now: avoid problems if they're from the array */
4262     for (dst = MARK, i = newlen; i; i--) {
4263         SV * const h = *dst;
4264         *dst++ = newSVsv(h);
4265     }
4266
4267     if (diff < 0) {                             /* shrinking the area */
4268         SV **tmparyval = NULL;
4269         if (newlen) {
4270             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4271             Copy(MARK, tmparyval, newlen, SV*);
4272         }
4273
4274         MARK = ORIGMARK + 1;
4275         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4276             MEXTEND(MARK, length);
4277             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4278             if (AvREAL(ary)) {
4279                 EXTEND_MORTAL(length);
4280                 for (i = length, dst = MARK; i; i--) {
4281                     sv_2mortal(*dst);   /* free them eventualy */
4282                     dst++;
4283                 }
4284             }
4285             MARK += length - 1;
4286         }
4287         else {
4288             *MARK = AvARRAY(ary)[offset+length-1];
4289             if (AvREAL(ary)) {
4290                 sv_2mortal(*MARK);
4291                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4292                     SvREFCNT_dec(*dst++);       /* free them now */
4293             }
4294         }
4295         AvFILLp(ary) += diff;
4296
4297         /* pull up or down? */
4298
4299         if (offset < after) {                   /* easier to pull up */
4300             if (offset) {                       /* esp. if nothing to pull */
4301                 src = &AvARRAY(ary)[offset-1];
4302                 dst = src - diff;               /* diff is negative */
4303                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4304                     *dst-- = *src--;
4305             }
4306             dst = AvARRAY(ary);
4307             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4308             AvMAX(ary) += diff;
4309         }
4310         else {
4311             if (after) {                        /* anything to pull down? */
4312                 src = AvARRAY(ary) + offset + length;
4313                 dst = src + diff;               /* diff is negative */
4314                 Move(src, dst, after, SV*);
4315             }
4316             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4317                                                 /* avoid later double free */
4318         }
4319         i = -diff;
4320         while (i)
4321             dst[--i] = &PL_sv_undef;
4322
4323         if (newlen) {
4324             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4325             Safefree(tmparyval);
4326         }
4327     }
4328     else {                                      /* no, expanding (or same) */
4329         SV** tmparyval = NULL;
4330         if (length) {
4331             Newx(tmparyval, length, SV*);       /* so remember deletion */
4332             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4333         }
4334
4335         if (diff > 0) {                         /* expanding */
4336             /* push up or down? */
4337             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4338                 if (offset) {
4339                     src = AvARRAY(ary);
4340                     dst = src - diff;
4341                     Move(src, dst, offset, SV*);
4342                 }
4343                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4344                 AvMAX(ary) += diff;
4345                 AvFILLp(ary) += diff;
4346             }
4347             else {
4348                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4349                     av_extend(ary, AvFILLp(ary) + diff);
4350                 AvFILLp(ary) += diff;
4351
4352                 if (after) {
4353                     dst = AvARRAY(ary) + AvFILLp(ary);
4354                     src = dst - diff;
4355                     for (i = after; i; i--) {
4356                         *dst-- = *src--;
4357                     }
4358                 }
4359             }
4360         }
4361
4362         if (newlen) {
4363             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4364         }
4365
4366         MARK = ORIGMARK + 1;
4367         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4368             if (length) {
4369                 Copy(tmparyval, MARK, length, SV*);
4370                 if (AvREAL(ary)) {
4371                     EXTEND_MORTAL(length);
4372                     for (i = length, dst = MARK; i; i--) {
4373                         sv_2mortal(*dst);       /* free them eventualy */
4374                         dst++;
4375                     }
4376                 }
4377             }
4378             MARK += length - 1;
4379         }
4380         else if (length--) {
4381             *MARK = tmparyval[length];
4382             if (AvREAL(ary)) {
4383                 sv_2mortal(*MARK);
4384                 while (length-- > 0)
4385                     SvREFCNT_dec(tmparyval[length]);
4386             }
4387         }
4388         else
4389             *MARK = &PL_sv_undef;
4390         Safefree(tmparyval);
4391     }
4392     SP = MARK;
4393     RETURN;
4394 }
4395
4396 PP(pp_push)
4397 {
4398     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4399     register AV * const ary = (AV*)*++MARK;
4400     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4401
4402     if (mg) {
4403         *MARK-- = SvTIED_obj((SV*)ary, mg);
4404         PUSHMARK(MARK);
4405         PUTBACK;
4406         ENTER;
4407         call_method("PUSH",G_SCALAR|G_DISCARD);
4408         LEAVE;
4409         SPAGAIN;
4410         SP = ORIGMARK;
4411         PUSHi( AvFILL(ary) + 1 );
4412     }
4413     else {
4414         for (++MARK; MARK <= SP; MARK++) {
4415             SV * const sv = newSV(0);
4416             if (*MARK)
4417                 sv_setsv(sv, *MARK);
4418             av_store(ary, AvFILLp(ary)+1, sv);
4419         }
4420         SP = ORIGMARK;
4421         PUSHi( AvFILLp(ary) + 1 );
4422     }
4423     RETURN;
4424 }
4425
4426 PP(pp_shift)
4427 {
4428     dVAR;
4429     dSP;
4430     AV * const av = (AV*)POPs;
4431     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4432     EXTEND(SP, 1);
4433     assert (sv);
4434     if (AvREAL(av))
4435         (void)sv_2mortal(sv);
4436     PUSHs(sv);
4437     RETURN;
4438 }
4439
4440 PP(pp_unshift)
4441 {
4442     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4443     register AV *ary = (AV*)*++MARK;
4444     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4445
4446     if (mg) {
4447         *MARK-- = SvTIED_obj((SV*)ary, mg);
4448         PUSHMARK(MARK);
4449         PUTBACK;
4450         ENTER;
4451         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4452         LEAVE;
4453         SPAGAIN;
4454     }
4455     else {
4456         register I32 i = 0;
4457         av_unshift(ary, SP - MARK);
4458         while (MARK < SP) {
4459             SV * const sv = newSVsv(*++MARK);
4460             (void)av_store(ary, i++, sv);
4461         }
4462     }
4463     SP = ORIGMARK;
4464     PUSHi( AvFILL(ary) + 1 );
4465     RETURN;
4466 }
4467
4468 PP(pp_reverse)
4469 {
4470     dVAR; dSP; dMARK;
4471     SV ** const oldsp = SP;
4472
4473     if (GIMME == G_ARRAY) {
4474         MARK++;
4475         while (MARK < SP) {
4476             register SV * const tmp = *MARK;
4477             *MARK++ = *SP;
4478             *SP-- = tmp;
4479         }
4480         /* safe as long as stack cannot get extended in the above */
4481         SP = oldsp;
4482     }
4483     else {
4484         register char *up;
4485         register char *down;
4486         register I32 tmp;
4487         dTARGET;
4488         STRLEN len;
4489         PADOFFSET padoff_du;
4490
4491         SvUTF8_off(TARG);                               /* decontaminate */
4492         if (SP - MARK > 1)
4493             do_join(TARG, &PL_sv_no, MARK, SP);
4494         else
4495             sv_setsv(TARG, (SP > MARK)
4496                     ? *SP
4497                     : (padoff_du = find_rundefsvoffset(),
4498                         (padoff_du == NOT_IN_PAD
4499                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4500                         ? DEFSV : PAD_SVl(padoff_du)));
4501         up = SvPV_force(TARG, len);
4502         if (len > 1) {
4503             if (DO_UTF8(TARG)) {        /* first reverse each character */
4504                 U8* s = (U8*)SvPVX(TARG);
4505                 const U8* send = (U8*)(s + len);
4506                 while (s < send) {
4507                     if (UTF8_IS_INVARIANT(*s)) {
4508                         s++;
4509                         continue;
4510                     }
4511                     else {
4512                         if (!utf8_to_uvchr(s, 0))
4513                             break;
4514                         up = (char*)s;
4515                         s += UTF8SKIP(s);
4516                         down = (char*)(s - 1);
4517                         /* reverse this character */
4518                         while (down > up) {
4519                             tmp = *up;
4520                             *up++ = *down;
4521                             *down-- = (char)tmp;
4522                         }
4523                     }
4524                 }
4525                 up = SvPVX(TARG);
4526             }
4527             down = SvPVX(TARG) + len - 1;
4528             while (down > up) {
4529                 tmp = *up;
4530                 *up++ = *down;
4531                 *down-- = (char)tmp;
4532             }
4533             (void)SvPOK_only_UTF8(TARG);
4534         }
4535         SP = MARK + 1;
4536         SETTARG;
4537     }
4538     RETURN;
4539 }
4540
4541 PP(pp_split)
4542 {
4543     dVAR; dSP; dTARG;
4544     AV *ary;
4545     register IV limit = POPi;                   /* note, negative is forever */
4546     SV * const sv = POPs;
4547     STRLEN len;
4548     register const char *s = SvPV_const(sv, len);
4549     const bool do_utf8 = DO_UTF8(sv);
4550     const char *strend = s + len;
4551     register PMOP *pm;
4552     register REGEXP *rx;
4553     register SV *dstr;
4554     register const char *m;
4555     I32 iters = 0;
4556     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4557     I32 maxiters = slen + 10;
4558     const char *orig;
4559     const I32 origlimit = limit;
4560     I32 realarray = 0;
4561     I32 base;
4562     const I32 gimme = GIMME_V;
4563     const I32 oldsave = PL_savestack_ix;
4564     I32 make_mortal = 1;
4565     bool multiline = 0;
4566     MAGIC *mg = NULL;
4567
4568 #ifdef DEBUGGING
4569     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4570 #else
4571     pm = (PMOP*)POPs;
4572 #endif
4573     if (!pm || !s)
4574         DIE(aTHX_ "panic: pp_split");
4575     rx = PM_GETRE(pm);
4576
4577     TAINT_IF((rx->extflags & RXf_PMf_LOCALE) &&
4578              (rx->extflags & (RXf_WHITE | RXf_SKIPWHITE)));
4579
4580     RX_MATCH_UTF8_set(rx, do_utf8);
4581
4582 #ifdef USE_ITHREADS
4583     if (pm->op_pmreplrootu.op_pmtargetoff) {
4584         ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4585     }
4586 #else
4587     if (pm->op_pmreplrootu.op_pmtargetgv) {
4588         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4589     }
4590 #endif
4591     else if (gimme != G_ARRAY)
4592         ary = GvAVn(PL_defgv);
4593     else
4594         ary = NULL;
4595     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4596         realarray = 1;
4597         PUTBACK;
4598         av_extend(ary,0);
4599         av_clear(ary);
4600         SPAGAIN;
4601         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4602             PUSHMARK(SP);
4603             XPUSHs(SvTIED_obj((SV*)ary, mg));
4604         }
4605         else {
4606             if (!AvREAL(ary)) {
4607                 I32 i;
4608                 AvREAL_on(ary);
4609                 AvREIFY_off(ary);
4610                 for (i = AvFILLp(ary); i >= 0; i--)
4611                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4612             }
4613             /* temporarily switch stacks */
4614             SAVESWITCHSTACK(PL_curstack, ary);
4615             make_mortal = 0;
4616         }
4617     }
4618     base = SP - PL_stack_base;
4619     orig = s;
4620     if (rx->extflags & RXf_SKIPWHITE) {
4621         if (do_utf8) {
4622             while (*s == ' ' || is_utf8_space((U8*)s))
4623                 s += UTF8SKIP(s);
4624         }
4625         else if (rx->extflags & RXf_PMf_LOCALE) {
4626             while (isSPACE_LC(*s))
4627                 s++;
4628         }
4629         else {
4630             while (isSPACE(*s))
4631                 s++;
4632         }
4633     }
4634     if (rx->extflags & PMf_MULTILINE) {
4635         multiline = 1;
4636     }
4637
4638     if (!limit)
4639         limit = maxiters + 2;
4640     if (rx->extflags & RXf_WHITE) {
4641         while (--limit) {
4642             m = s;
4643             /* this one uses 'm' and is a negative test */
4644             if (do_utf8) {
4645                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4646                     const int t = UTF8SKIP(m);
4647                     /* is_utf8_space returns FALSE for malform utf8 */
4648                     if (strend - m < t)
4649                         m = strend;
4650                     else
4651                         m += t;
4652                 }
4653             } else if (rx->extflags & RXf_PMf_LOCALE) {
4654                 while (m < strend && !isSPACE_LC(*m))
4655                     ++m;
4656             } else {
4657                 while (m < strend && !isSPACE(*m))
4658                     ++m;
4659             }
4660             if (m >= strend)
4661                 break;
4662
4663             dstr = newSVpvn(s, m-s);
4664             if (make_mortal)
4665                 sv_2mortal(dstr);
4666             if (do_utf8)
4667                 (void)SvUTF8_on(dstr);
4668             XPUSHs(dstr);
4669
4670             /* skip the whitespace found last */
4671             if (do_utf8)
4672                 s = m + UTF8SKIP(m);
4673             else
4674                 s = m + 1;
4675
4676             /* this one uses 's' and is a positive test */
4677             if (do_utf8) {
4678                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4679                     s +=  UTF8SKIP(s);
4680             } else if (rx->extflags & RXf_PMf_LOCALE) {
4681                 while (s < strend && isSPACE_LC(*s))
4682                     ++s;
4683             } else {
4684                 while (s < strend && isSPACE(*s))
4685                     ++s;
4686             }
4687         }
4688     }
4689     else if (rx->extflags & RXf_START_ONLY) {
4690         while (--limit) {
4691             for (m = s; m < strend && *m != '\n'; m++)
4692                 ;
4693             m++;
4694             if (m >= strend)
4695                 break;
4696             dstr = newSVpvn(s, m-s);
4697             if (make_mortal)
4698                 sv_2mortal(dstr);
4699             if (do_utf8)
4700                 (void)SvUTF8_on(dstr);
4701             XPUSHs(dstr);
4702             s = m;
4703         }
4704     }
4705     else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
4706              (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
4707              && (rx->extflags & RXf_CHECK_ALL)
4708              && !(rx->extflags & RXf_ANCH)) {
4709         const int tail = (rx->extflags & RXf_INTUIT_TAIL);
4710         SV * const csv = CALLREG_INTUIT_STRING(rx);
4711
4712         len = rx->minlenret;
4713         if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
4714             const char c = *SvPV_nolen_const(csv);
4715             while (--limit) {
4716                 for (m = s; m < strend && *m != c; m++)
4717                     ;
4718                 if (m >= strend)
4719                     break;
4720                 dstr = newSVpvn(s, m-s);
4721                 if (make_mortal)
4722                     sv_2mortal(dstr);
4723                 if (do_utf8)
4724                     (void)SvUTF8_on(dstr);
4725                 XPUSHs(dstr);
4726                 /* The rx->minlen is in characters but we want to step
4727                  * s ahead by bytes. */
4728                 if (do_utf8)
4729                     s = (char*)utf8_hop((U8*)m, len);
4730                 else
4731                     s = m + len; /* Fake \n at the end */
4732             }
4733         }
4734         else {
4735             while (s < strend && --limit &&
4736               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4737                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4738             {
4739                 dstr = newSVpvn(s, m-s);
4740                 if (make_mortal)
4741                     sv_2mortal(dstr);
4742                 if (do_utf8)
4743                     (void)SvUTF8_on(dstr);
4744                 XPUSHs(dstr);
4745                 /* The rx->minlen is in characters but we want to step
4746                  * s ahead by bytes. */
4747                 if (do_utf8)
4748                     s = (char*)utf8_hop((U8*)m, len);
4749                 else
4750                     s = m + len; /* Fake \n at the end */
4751             }
4752         }
4753     }
4754     else {
4755         maxiters += slen * rx->nparens;
4756         while (s < strend && --limit)
4757         {
4758             I32 rex_return;
4759             PUTBACK;
4760             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4761                             sv, NULL, 0);
4762             SPAGAIN;
4763             if (rex_return == 0)
4764                 break;
4765             TAINT_IF(RX_MATCH_TAINTED(rx));
4766             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4767                 m = s;
4768                 s = orig;
4769                 orig = rx->subbeg;
4770                 s = orig + (m - s);
4771                 strend = s + (strend - m);
4772             }
4773             m = rx->offs[0].start + orig;
4774             dstr = newSVpvn(s, m-s);
4775             if (make_mortal)
4776                 sv_2mortal(dstr);
4777             if (do_utf8)
4778                 (void)SvUTF8_on(dstr);
4779             XPUSHs(dstr);
4780             if (rx->nparens) {
4781                 I32 i;
4782                 for (i = 1; i <= (I32)rx->nparens; i++) {
4783                     s = rx->offs[i].start + orig;
4784                     m = rx->offs[i].end + orig;
4785
4786                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4787                        parens that didn't match -- they should be set to
4788                        undef, not the empty string */
4789                     if (m >= orig && s >= orig) {
4790                         dstr = newSVpvn(s, m-s);
4791                     }
4792                     else
4793                         dstr = &PL_sv_undef;  /* undef, not "" */
4794                     if (make_mortal)
4795                         sv_2mortal(dstr);
4796                     if (do_utf8)
4797                         (void)SvUTF8_on(dstr);
4798                     XPUSHs(dstr);
4799                 }
4800             }
4801             s = rx->offs[0].end + orig;
4802         }
4803     }
4804
4805     iters = (SP - PL_stack_base) - base;
4806     if (iters > maxiters)
4807         DIE(aTHX_ "Split loop");
4808
4809     /* keep field after final delim? */
4810     if (s < strend || (iters && origlimit)) {
4811         const STRLEN l = strend - s;
4812         dstr = newSVpvn(s, l);
4813         if (make_mortal)
4814             sv_2mortal(dstr);
4815         if (do_utf8)
4816             (void)SvUTF8_on(dstr);
4817         XPUSHs(dstr);
4818         iters++;
4819     }
4820     else if (!origlimit) {
4821         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4822             if (TOPs && !make_mortal)
4823                 sv_2mortal(TOPs);
4824             iters--;
4825             *SP-- = &PL_sv_undef;
4826         }
4827     }
4828
4829     PUTBACK;
4830     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4831     SPAGAIN;
4832     if (realarray) {
4833         if (!mg) {
4834             if (SvSMAGICAL(ary)) {
4835                 PUTBACK;
4836                 mg_set((SV*)ary);
4837                 SPAGAIN;
4838             }
4839             if (gimme == G_ARRAY) {
4840                 EXTEND(SP, iters);
4841                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4842                 SP += iters;
4843                 RETURN;
4844             }
4845         }
4846         else {
4847             PUTBACK;
4848             ENTER;
4849             call_method("PUSH",G_SCALAR|G_DISCARD);
4850             LEAVE;
4851             SPAGAIN;
4852             if (gimme == G_ARRAY) {
4853                 I32 i;
4854                 /* EXTEND should not be needed - we just popped them */
4855                 EXTEND(SP, iters);
4856                 for (i=0; i < iters; i++) {
4857                     SV **svp = av_fetch(ary, i, FALSE);
4858                     PUSHs((svp) ? *svp : &PL_sv_undef);
4859                 }
4860                 RETURN;
4861             }
4862         }
4863     }
4864     else {
4865         if (gimme == G_ARRAY)
4866             RETURN;
4867     }
4868
4869     GETTARGET;
4870     PUSHi(iters);
4871     RETURN;
4872 }
4873
4874 PP(pp_lock)
4875 {
4876     dVAR;
4877     dSP;
4878     dTOPss;
4879     SV *retsv = sv;
4880     SvLOCK(sv);
4881     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4882         || SvTYPE(retsv) == SVt_PVCV) {
4883         retsv = refto(retsv);
4884     }
4885     SETs(retsv);
4886     RETURN;
4887 }
4888
4889
4890 PP(unimplemented_op)
4891 {
4892     dVAR;
4893     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4894         PL_op->op_type);
4895 }
4896
4897 /*
4898  * Local variables:
4899  * c-indentation-style: bsd
4900  * c-basic-offset: 4
4901  * indent-tabs-mode: t
4902  * End:
4903  *
4904  * ex: set ts=8 sts=4 sw=4 noet:
4905  */