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 (right == 0.0)
1310             DIE(aTHX_ "Illegal division by zero");
1311         PUSHn( left / right );
1312         RETURN;
1313     }
1314 }
1315
1316 PP(pp_modulo)
1317 {
1318     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1319     {
1320         UV left  = 0;
1321         UV right = 0;
1322         bool left_neg = FALSE;
1323         bool right_neg = FALSE;
1324         bool use_double = FALSE;
1325         bool dright_valid = FALSE;
1326         NV dright = 0.0;
1327         NV dleft  = 0.0;
1328
1329         SvIV_please(TOPs);
1330         if (SvIOK(TOPs)) {
1331             right_neg = !SvUOK(TOPs);
1332             if (!right_neg) {
1333                 right = SvUVX(POPs);
1334             } else {
1335                 const IV biv = SvIVX(POPs);
1336                 if (biv >= 0) {
1337                     right = biv;
1338                     right_neg = FALSE; /* effectively it's a UV now */
1339                 } else {
1340                     right = -biv;
1341                 }
1342             }
1343         }
1344         else {
1345             dright = POPn;
1346             right_neg = dright < 0;
1347             if (right_neg)
1348                 dright = -dright;
1349             if (dright < UV_MAX_P1) {
1350                 right = U_V(dright);
1351                 dright_valid = TRUE; /* In case we need to use double below.  */
1352             } else {
1353                 use_double = TRUE;
1354             }
1355         }
1356
1357         /* At this point use_double is only true if right is out of range for
1358            a UV.  In range NV has been rounded down to nearest UV and
1359            use_double false.  */
1360         SvIV_please(TOPs);
1361         if (!use_double && SvIOK(TOPs)) {
1362             if (SvIOK(TOPs)) {
1363                 left_neg = !SvUOK(TOPs);
1364                 if (!left_neg) {
1365                     left = SvUVX(POPs);
1366                 } else {
1367                     const IV aiv = SvIVX(POPs);
1368                     if (aiv >= 0) {
1369                         left = aiv;
1370                         left_neg = FALSE; /* effectively it's a UV now */
1371                     } else {
1372                         left = -aiv;
1373                     }
1374                 }
1375             }
1376         }
1377         else {
1378             dleft = POPn;
1379             left_neg = dleft < 0;
1380             if (left_neg)
1381                 dleft = -dleft;
1382
1383             /* This should be exactly the 5.6 behaviour - if left and right are
1384                both in range for UV then use U_V() rather than floor.  */
1385             if (!use_double) {
1386                 if (dleft < UV_MAX_P1) {
1387                     /* right was in range, so is dleft, so use UVs not double.
1388                      */
1389                     left = U_V(dleft);
1390                 }
1391                 /* left is out of range for UV, right was in range, so promote
1392                    right (back) to double.  */
1393                 else {
1394                     /* The +0.5 is used in 5.6 even though it is not strictly
1395                        consistent with the implicit +0 floor in the U_V()
1396                        inside the #if 1. */
1397                     dleft = Perl_floor(dleft + 0.5);
1398                     use_double = TRUE;
1399                     if (dright_valid)
1400                         dright = Perl_floor(dright + 0.5);
1401                     else
1402                         dright = right;
1403                 }
1404             }
1405         }
1406         if (use_double) {
1407             NV dans;
1408
1409             if (!dright)
1410                 DIE(aTHX_ "Illegal modulus zero");
1411
1412             dans = Perl_fmod(dleft, dright);
1413             if ((left_neg != right_neg) && dans)
1414                 dans = dright - dans;
1415             if (right_neg)
1416                 dans = -dans;
1417             sv_setnv(TARG, dans);
1418         }
1419         else {
1420             UV ans;
1421
1422             if (!right)
1423                 DIE(aTHX_ "Illegal modulus zero");
1424
1425             ans = left % right;
1426             if ((left_neg != right_neg) && ans)
1427                 ans = right - ans;
1428             if (right_neg) {
1429                 /* XXX may warn: unary minus operator applied to unsigned type */
1430                 /* could change -foo to be (~foo)+1 instead     */
1431                 if (ans <= ~((UV)IV_MAX)+1)
1432                     sv_setiv(TARG, ~ans+1);
1433                 else
1434                     sv_setnv(TARG, -(NV)ans);
1435             }
1436             else
1437                 sv_setuv(TARG, ans);
1438         }
1439         PUSHTARG;
1440         RETURN;
1441     }
1442 }
1443
1444 PP(pp_repeat)
1445 {
1446   dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1447   {
1448     register IV count;
1449     dPOPss;
1450     SvGETMAGIC(sv);
1451     if (SvIOKp(sv)) {
1452          if (SvUOK(sv)) {
1453               const UV uv = SvUV(sv);
1454               if (uv > IV_MAX)
1455                    count = IV_MAX; /* The best we can do? */
1456               else
1457                    count = uv;
1458          } else {
1459               const IV iv = SvIV(sv);
1460               if (iv < 0)
1461                    count = 0;
1462               else
1463                    count = iv;
1464          }
1465     }
1466     else if (SvNOKp(sv)) {
1467          const NV nv = SvNV(sv);
1468          if (nv < 0.0)
1469               count = 0;
1470          else
1471               count = (IV)nv;
1472     }
1473     else
1474          count = SvIVx(sv);
1475     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1476         dMARK;
1477         static const char oom_list_extend[] = "Out of memory during list extend";
1478         const I32 items = SP - MARK;
1479         const I32 max = items * count;
1480
1481         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1482         /* Did the max computation overflow? */
1483         if (items > 0 && max > 0 && (max < items || max < count))
1484            Perl_croak(aTHX_ oom_list_extend);
1485         MEXTEND(MARK, max);
1486         if (count > 1) {
1487             while (SP > MARK) {
1488 #if 0
1489               /* This code was intended to fix 20010809.028:
1490
1491                  $x = 'abcd';
1492                  for (($x =~ /./g) x 2) {
1493                      print chop; # "abcdabcd" expected as output.
1494                  }
1495
1496                * but that change (#11635) broke this code:
1497
1498                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1499
1500                * I can't think of a better fix that doesn't introduce
1501                * an efficiency hit by copying the SVs. The stack isn't
1502                * refcounted, and mortalisation obviously doesn't
1503                * Do The Right Thing when the stack has more than
1504                * one pointer to the same mortal value.
1505                * .robin.
1506                */
1507                 if (*SP) {
1508                     *SP = sv_2mortal(newSVsv(*SP));
1509                     SvREADONLY_on(*SP);
1510                 }
1511 #else
1512                if (*SP)
1513                    SvTEMP_off((*SP));
1514 #endif
1515                 SP--;
1516             }
1517             MARK++;
1518             repeatcpy((char*)(MARK + items), (char*)MARK,
1519                 items * sizeof(SV*), count - 1);
1520             SP += max;
1521         }
1522         else if (count <= 0)
1523             SP -= items;
1524     }
1525     else {      /* Note: mark already snarfed by pp_list */
1526         SV * const tmpstr = POPs;
1527         STRLEN len;
1528         bool isutf;
1529         static const char oom_string_extend[] =
1530           "Out of memory during string extend";
1531
1532         SvSetSV(TARG, tmpstr);
1533         SvPV_force(TARG, len);
1534         isutf = DO_UTF8(TARG);
1535         if (count != 1) {
1536             if (count < 1)
1537                 SvCUR_set(TARG, 0);
1538             else {
1539                 const STRLEN max = (UV)count * len;
1540                 if (len > ((MEM_SIZE)~0)/count)
1541                      Perl_croak(aTHX_ oom_string_extend);
1542                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1543                 SvGROW(TARG, max + 1);
1544                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1545                 SvCUR_set(TARG, SvCUR(TARG) * count);
1546             }
1547             *SvEND(TARG) = '\0';
1548         }
1549         if (isutf)
1550             (void)SvPOK_only_UTF8(TARG);
1551         else
1552             (void)SvPOK_only(TARG);
1553
1554         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1555             /* The parser saw this as a list repeat, and there
1556                are probably several items on the stack. But we're
1557                in scalar context, and there's no pp_list to save us
1558                now. So drop the rest of the items -- robin@kitsite.com
1559              */
1560             dMARK;
1561             SP = MARK;
1562         }
1563         PUSHTARG;
1564     }
1565     RETURN;
1566   }
1567 }
1568
1569 PP(pp_subtract)
1570 {
1571     dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1572     useleft = USE_LEFT(TOPm1s);
1573 #ifdef PERL_PRESERVE_IVUV
1574     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1575        "bad things" happen if you rely on signed integers wrapping.  */
1576     SvIV_please(TOPs);
1577     if (SvIOK(TOPs)) {
1578         /* Unless the left argument is integer in range we are going to have to
1579            use NV maths. Hence only attempt to coerce the right argument if
1580            we know the left is integer.  */
1581         register UV auv = 0;
1582         bool auvok = FALSE;
1583         bool a_valid = 0;
1584
1585         if (!useleft) {
1586             auv = 0;
1587             a_valid = auvok = 1;
1588             /* left operand is undef, treat as zero.  */
1589         } else {
1590             /* Left operand is defined, so is it IV? */
1591             SvIV_please(TOPm1s);
1592             if (SvIOK(TOPm1s)) {
1593                 if ((auvok = SvUOK(TOPm1s)))
1594                     auv = SvUVX(TOPm1s);
1595                 else {
1596                     register const IV aiv = SvIVX(TOPm1s);
1597                     if (aiv >= 0) {
1598                         auv = aiv;
1599                         auvok = 1;      /* Now acting as a sign flag.  */
1600                     } else { /* 2s complement assumption for IV_MIN */
1601                         auv = (UV)-aiv;
1602                     }
1603                 }
1604                 a_valid = 1;
1605             }
1606         }
1607         if (a_valid) {
1608             bool result_good = 0;
1609             UV result;
1610             register UV buv;
1611             bool buvok = SvUOK(TOPs);
1612
1613             if (buvok)
1614                 buv = SvUVX(TOPs);
1615             else {
1616                 register const IV biv = SvIVX(TOPs);
1617                 if (biv >= 0) {
1618                     buv = biv;
1619                     buvok = 1;
1620                 } else
1621                     buv = (UV)-biv;
1622             }
1623             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1624                else "IV" now, independent of how it came in.
1625                if a, b represents positive, A, B negative, a maps to -A etc
1626                a - b =>  (a - b)
1627                A - b => -(a + b)
1628                a - B =>  (a + b)
1629                A - B => -(a - b)
1630                all UV maths. negate result if A negative.
1631                subtract if signs same, add if signs differ. */
1632
1633             if (auvok ^ buvok) {
1634                 /* Signs differ.  */
1635                 result = auv + buv;
1636                 if (result >= auv)
1637                     result_good = 1;
1638             } else {
1639                 /* Signs same */
1640                 if (auv >= buv) {
1641                     result = auv - buv;
1642                     /* Must get smaller */
1643                     if (result <= auv)
1644                         result_good = 1;
1645                 } else {
1646                     result = buv - auv;
1647                     if (result <= buv) {
1648                         /* result really should be -(auv-buv). as its negation
1649                            of true value, need to swap our result flag  */
1650                         auvok = !auvok;
1651                         result_good = 1;
1652                     }
1653                 }
1654             }
1655             if (result_good) {
1656                 SP--;
1657                 if (auvok)
1658                     SETu( result );
1659                 else {
1660                     /* Negate result */
1661                     if (result <= (UV)IV_MIN)
1662                         SETi( -(IV)result );
1663                     else {
1664                         /* result valid, but out of range for IV.  */
1665                         SETn( -(NV)result );
1666                     }
1667                 }
1668                 RETURN;
1669             } /* Overflow, drop through to NVs.  */
1670         }
1671     }
1672 #endif
1673     useleft = USE_LEFT(TOPm1s);
1674     {
1675         dPOPnv;
1676         if (!useleft) {
1677             /* left operand is undef, treat as zero - value */
1678             SETn(-value);
1679             RETURN;
1680         }
1681         SETn( TOPn - value );
1682         RETURN;
1683     }
1684 }
1685
1686 PP(pp_left_shift)
1687 {
1688     dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1689     {
1690       const IV shift = POPi;
1691       if (PL_op->op_private & HINT_INTEGER) {
1692         const IV i = TOPi;
1693         SETi(i << shift);
1694       }
1695       else {
1696         const UV u = TOPu;
1697         SETu(u << shift);
1698       }
1699       RETURN;
1700     }
1701 }
1702
1703 PP(pp_right_shift)
1704 {
1705     dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1706     {
1707       const IV shift = POPi;
1708       if (PL_op->op_private & HINT_INTEGER) {
1709         const IV i = TOPi;
1710         SETi(i >> shift);
1711       }
1712       else {
1713         const UV u = TOPu;
1714         SETu(u >> shift);
1715       }
1716       RETURN;
1717     }
1718 }
1719
1720 PP(pp_lt)
1721 {
1722     dVAR; dSP; tryAMAGICbinSET(lt,0);
1723 #ifdef PERL_PRESERVE_IVUV
1724     SvIV_please(TOPs);
1725     if (SvIOK(TOPs)) {
1726         SvIV_please(TOPm1s);
1727         if (SvIOK(TOPm1s)) {
1728             bool auvok = SvUOK(TOPm1s);
1729             bool buvok = SvUOK(TOPs);
1730
1731             if (!auvok && !buvok) { /* ## IV < IV ## */
1732                 const IV aiv = SvIVX(TOPm1s);
1733                 const IV biv = SvIVX(TOPs);
1734
1735                 SP--;
1736                 SETs(boolSV(aiv < biv));
1737                 RETURN;
1738             }
1739             if (auvok && buvok) { /* ## UV < UV ## */
1740                 const UV auv = SvUVX(TOPm1s);
1741                 const UV buv = SvUVX(TOPs);
1742
1743                 SP--;
1744                 SETs(boolSV(auv < buv));
1745                 RETURN;
1746             }
1747             if (auvok) { /* ## UV < IV ## */
1748                 UV auv;
1749                 const IV biv = SvIVX(TOPs);
1750                 SP--;
1751                 if (biv < 0) {
1752                     /* As (a) is a UV, it's >=0, so it cannot be < */
1753                     SETs(&PL_sv_no);
1754                     RETURN;
1755                 }
1756                 auv = SvUVX(TOPs);
1757                 SETs(boolSV(auv < (UV)biv));
1758                 RETURN;
1759             }
1760             { /* ## IV < UV ## */
1761                 const IV aiv = SvIVX(TOPm1s);
1762                 UV buv;
1763
1764                 if (aiv < 0) {
1765                     /* As (b) is a UV, it's >=0, so it must be < */
1766                     SP--;
1767                     SETs(&PL_sv_yes);
1768                     RETURN;
1769                 }
1770                 buv = SvUVX(TOPs);
1771                 SP--;
1772                 SETs(boolSV((UV)aiv < buv));
1773                 RETURN;
1774             }
1775         }
1776     }
1777 #endif
1778 #ifndef NV_PRESERVES_UV
1779 #ifdef PERL_PRESERVE_IVUV
1780     else
1781 #endif
1782     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1783         SP--;
1784         SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1785         RETURN;
1786     }
1787 #endif
1788     {
1789 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1790       dPOPTOPnnrl;
1791       if (Perl_isnan(left) || Perl_isnan(right))
1792           RETSETNO;
1793       SETs(boolSV(left < right));
1794 #else
1795       dPOPnv;
1796       SETs(boolSV(TOPn < value));
1797 #endif
1798       RETURN;
1799     }
1800 }
1801
1802 PP(pp_gt)
1803 {
1804     dVAR; dSP; tryAMAGICbinSET(gt,0);
1805 #ifdef PERL_PRESERVE_IVUV
1806     SvIV_please(TOPs);
1807     if (SvIOK(TOPs)) {
1808         SvIV_please(TOPm1s);
1809         if (SvIOK(TOPm1s)) {
1810             bool auvok = SvUOK(TOPm1s);
1811             bool buvok = SvUOK(TOPs);
1812
1813             if (!auvok && !buvok) { /* ## IV > IV ## */
1814                 const IV aiv = SvIVX(TOPm1s);
1815                 const IV biv = SvIVX(TOPs);
1816
1817                 SP--;
1818                 SETs(boolSV(aiv > biv));
1819                 RETURN;
1820             }
1821             if (auvok && buvok) { /* ## UV > UV ## */
1822                 const UV auv = SvUVX(TOPm1s);
1823                 const UV buv = SvUVX(TOPs);
1824
1825                 SP--;
1826                 SETs(boolSV(auv > buv));
1827                 RETURN;
1828             }
1829             if (auvok) { /* ## UV > IV ## */
1830                 UV auv;
1831                 const IV biv = SvIVX(TOPs);
1832
1833                 SP--;
1834                 if (biv < 0) {
1835                     /* As (a) is a UV, it's >=0, so it must be > */
1836                     SETs(&PL_sv_yes);
1837                     RETURN;
1838                 }
1839                 auv = SvUVX(TOPs);
1840                 SETs(boolSV(auv > (UV)biv));
1841                 RETURN;
1842             }
1843             { /* ## IV > UV ## */
1844                 const IV aiv = SvIVX(TOPm1s);
1845                 UV buv;
1846
1847                 if (aiv < 0) {
1848                     /* As (b) is a UV, it's >=0, so it cannot be > */
1849                     SP--;
1850                     SETs(&PL_sv_no);
1851                     RETURN;
1852                 }
1853                 buv = SvUVX(TOPs);
1854                 SP--;
1855                 SETs(boolSV((UV)aiv > buv));
1856                 RETURN;
1857             }
1858         }
1859     }
1860 #endif
1861 #ifndef NV_PRESERVES_UV
1862 #ifdef PERL_PRESERVE_IVUV
1863     else
1864 #endif
1865     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1866         SP--;
1867         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1868         RETURN;
1869     }
1870 #endif
1871     {
1872 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1873       dPOPTOPnnrl;
1874       if (Perl_isnan(left) || Perl_isnan(right))
1875           RETSETNO;
1876       SETs(boolSV(left > right));
1877 #else
1878       dPOPnv;
1879       SETs(boolSV(TOPn > value));
1880 #endif
1881       RETURN;
1882     }
1883 }
1884
1885 PP(pp_le)
1886 {
1887     dVAR; dSP; tryAMAGICbinSET(le,0);
1888 #ifdef PERL_PRESERVE_IVUV
1889     SvIV_please(TOPs);
1890     if (SvIOK(TOPs)) {
1891         SvIV_please(TOPm1s);
1892         if (SvIOK(TOPm1s)) {
1893             bool auvok = SvUOK(TOPm1s);
1894             bool buvok = SvUOK(TOPs);
1895
1896             if (!auvok && !buvok) { /* ## IV <= IV ## */
1897                 const IV aiv = SvIVX(TOPm1s);
1898                 const IV biv = SvIVX(TOPs);
1899
1900                 SP--;
1901                 SETs(boolSV(aiv <= biv));
1902                 RETURN;
1903             }
1904             if (auvok && buvok) { /* ## UV <= UV ## */
1905                 UV auv = SvUVX(TOPm1s);
1906                 UV buv = SvUVX(TOPs);
1907
1908                 SP--;
1909                 SETs(boolSV(auv <= buv));
1910                 RETURN;
1911             }
1912             if (auvok) { /* ## UV <= IV ## */
1913                 UV auv;
1914                 const IV biv = SvIVX(TOPs);
1915
1916                 SP--;
1917                 if (biv < 0) {
1918                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1919                     SETs(&PL_sv_no);
1920                     RETURN;
1921                 }
1922                 auv = SvUVX(TOPs);
1923                 SETs(boolSV(auv <= (UV)biv));
1924                 RETURN;
1925             }
1926             { /* ## IV <= UV ## */
1927                 const IV aiv = SvIVX(TOPm1s);
1928                 UV buv;
1929
1930                 if (aiv < 0) {
1931                     /* As (b) is a UV, it's >=0, so a must be <= */
1932                     SP--;
1933                     SETs(&PL_sv_yes);
1934                     RETURN;
1935                 }
1936                 buv = SvUVX(TOPs);
1937                 SP--;
1938                 SETs(boolSV((UV)aiv <= buv));
1939                 RETURN;
1940             }
1941         }
1942     }
1943 #endif
1944 #ifndef NV_PRESERVES_UV
1945 #ifdef PERL_PRESERVE_IVUV
1946     else
1947 #endif
1948     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1949         SP--;
1950         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1951         RETURN;
1952     }
1953 #endif
1954     {
1955 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1956       dPOPTOPnnrl;
1957       if (Perl_isnan(left) || Perl_isnan(right))
1958           RETSETNO;
1959       SETs(boolSV(left <= right));
1960 #else
1961       dPOPnv;
1962       SETs(boolSV(TOPn <= value));
1963 #endif
1964       RETURN;
1965     }
1966 }
1967
1968 PP(pp_ge)
1969 {
1970     dVAR; dSP; tryAMAGICbinSET(ge,0);
1971 #ifdef PERL_PRESERVE_IVUV
1972     SvIV_please(TOPs);
1973     if (SvIOK(TOPs)) {
1974         SvIV_please(TOPm1s);
1975         if (SvIOK(TOPm1s)) {
1976             bool auvok = SvUOK(TOPm1s);
1977             bool buvok = SvUOK(TOPs);
1978
1979             if (!auvok && !buvok) { /* ## IV >= IV ## */
1980                 const IV aiv = SvIVX(TOPm1s);
1981                 const IV biv = SvIVX(TOPs);
1982
1983                 SP--;
1984                 SETs(boolSV(aiv >= biv));
1985                 RETURN;
1986             }
1987             if (auvok && buvok) { /* ## UV >= UV ## */
1988                 const UV auv = SvUVX(TOPm1s);
1989                 const UV buv = SvUVX(TOPs);
1990
1991                 SP--;
1992                 SETs(boolSV(auv >= buv));
1993                 RETURN;
1994             }
1995             if (auvok) { /* ## UV >= IV ## */
1996                 UV auv;
1997                 const IV biv = SvIVX(TOPs);
1998
1999                 SP--;
2000                 if (biv < 0) {
2001                     /* As (a) is a UV, it's >=0, so it must be >= */
2002                     SETs(&PL_sv_yes);
2003                     RETURN;
2004                 }
2005                 auv = SvUVX(TOPs);
2006                 SETs(boolSV(auv >= (UV)biv));
2007                 RETURN;
2008             }
2009             { /* ## IV >= UV ## */
2010                 const IV aiv = SvIVX(TOPm1s);
2011                 UV buv;
2012
2013                 if (aiv < 0) {
2014                     /* As (b) is a UV, it's >=0, so a cannot be >= */
2015                     SP--;
2016                     SETs(&PL_sv_no);
2017                     RETURN;
2018                 }
2019                 buv = SvUVX(TOPs);
2020                 SP--;
2021                 SETs(boolSV((UV)aiv >= buv));
2022                 RETURN;
2023             }
2024         }
2025     }
2026 #endif
2027 #ifndef NV_PRESERVES_UV
2028 #ifdef PERL_PRESERVE_IVUV
2029     else
2030 #endif
2031     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2032         SP--;
2033         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2034         RETURN;
2035     }
2036 #endif
2037     {
2038 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2039       dPOPTOPnnrl;
2040       if (Perl_isnan(left) || Perl_isnan(right))
2041           RETSETNO;
2042       SETs(boolSV(left >= right));
2043 #else
2044       dPOPnv;
2045       SETs(boolSV(TOPn >= value));
2046 #endif
2047       RETURN;
2048     }
2049 }
2050
2051 PP(pp_ne)
2052 {
2053     dVAR; dSP; tryAMAGICbinSET(ne,0);
2054 #ifndef NV_PRESERVES_UV
2055     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2056         SP--;
2057         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2058         RETURN;
2059     }
2060 #endif
2061 #ifdef PERL_PRESERVE_IVUV
2062     SvIV_please(TOPs);
2063     if (SvIOK(TOPs)) {
2064         SvIV_please(TOPm1s);
2065         if (SvIOK(TOPm1s)) {
2066             const bool auvok = SvUOK(TOPm1s);
2067             const bool buvok = SvUOK(TOPs);
2068
2069             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2070                 /* Casting IV to UV before comparison isn't going to matter
2071                    on 2s complement. On 1s complement or sign&magnitude
2072                    (if we have any of them) it could make negative zero
2073                    differ from normal zero. As I understand it. (Need to
2074                    check - is negative zero implementation defined behaviour
2075                    anyway?). NWC  */
2076                 const UV buv = SvUVX(POPs);
2077                 const UV auv = SvUVX(TOPs);
2078
2079                 SETs(boolSV(auv != buv));
2080                 RETURN;
2081             }
2082             {                   /* ## Mixed IV,UV ## */
2083                 IV iv;
2084                 UV uv;
2085
2086                 /* != is commutative so swap if needed (save code) */
2087                 if (auvok) {
2088                     /* swap. top of stack (b) is the iv */
2089                     iv = SvIVX(TOPs);
2090                     SP--;
2091                     if (iv < 0) {
2092                         /* As (a) is a UV, it's >0, so it cannot be == */
2093                         SETs(&PL_sv_yes);
2094                         RETURN;
2095                     }
2096                     uv = SvUVX(TOPs);
2097                 } else {
2098                     iv = SvIVX(TOPm1s);
2099                     SP--;
2100                     if (iv < 0) {
2101                         /* As (b) is a UV, it's >0, so it cannot be == */
2102                         SETs(&PL_sv_yes);
2103                         RETURN;
2104                     }
2105                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2106                 }
2107                 SETs(boolSV((UV)iv != uv));
2108                 RETURN;
2109             }
2110         }
2111     }
2112 #endif
2113     {
2114 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2115       dPOPTOPnnrl;
2116       if (Perl_isnan(left) || Perl_isnan(right))
2117           RETSETYES;
2118       SETs(boolSV(left != right));
2119 #else
2120       dPOPnv;
2121       SETs(boolSV(TOPn != value));
2122 #endif
2123       RETURN;
2124     }
2125 }
2126
2127 PP(pp_ncmp)
2128 {
2129     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2130 #ifndef NV_PRESERVES_UV
2131     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2132         const UV right = PTR2UV(SvRV(POPs));
2133         const UV left = PTR2UV(SvRV(TOPs));
2134         SETi((left > right) - (left < right));
2135         RETURN;
2136     }
2137 #endif
2138 #ifdef PERL_PRESERVE_IVUV
2139     /* Fortunately it seems NaN isn't IOK */
2140     SvIV_please(TOPs);
2141     if (SvIOK(TOPs)) {
2142         SvIV_please(TOPm1s);
2143         if (SvIOK(TOPm1s)) {
2144             const bool leftuvok = SvUOK(TOPm1s);
2145             const bool rightuvok = SvUOK(TOPs);
2146             I32 value;
2147             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2148                 const IV leftiv = SvIVX(TOPm1s);
2149                 const IV rightiv = SvIVX(TOPs);
2150
2151                 if (leftiv > rightiv)
2152                     value = 1;
2153                 else if (leftiv < rightiv)
2154                     value = -1;
2155                 else
2156                     value = 0;
2157             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2158                 const UV leftuv = SvUVX(TOPm1s);
2159                 const UV rightuv = SvUVX(TOPs);
2160
2161                 if (leftuv > rightuv)
2162                     value = 1;
2163                 else if (leftuv < rightuv)
2164                     value = -1;
2165                 else
2166                     value = 0;
2167             } else if (leftuvok) { /* ## UV <=> IV ## */
2168                 const IV rightiv = SvIVX(TOPs);
2169                 if (rightiv < 0) {
2170                     /* As (a) is a UV, it's >=0, so it cannot be < */
2171                     value = 1;
2172                 } else {
2173                     const UV leftuv = SvUVX(TOPm1s);
2174                     if (leftuv > (UV)rightiv) {
2175                         value = 1;
2176                     } else if (leftuv < (UV)rightiv) {
2177                         value = -1;
2178                     } else {
2179                         value = 0;
2180                     }
2181                 }
2182             } else { /* ## IV <=> UV ## */
2183                 const IV leftiv = SvIVX(TOPm1s);
2184                 if (leftiv < 0) {
2185                     /* As (b) is a UV, it's >=0, so it must be < */
2186                     value = -1;
2187                 } else {
2188                     const UV rightuv = SvUVX(TOPs);
2189                     if ((UV)leftiv > rightuv) {
2190                         value = 1;
2191                     } else if ((UV)leftiv < rightuv) {
2192                         value = -1;
2193                     } else {
2194                         value = 0;
2195                     }
2196                 }
2197             }
2198             SP--;
2199             SETi(value);
2200             RETURN;
2201         }
2202     }
2203 #endif
2204     {
2205       dPOPTOPnnrl;
2206       I32 value;
2207
2208 #ifdef Perl_isnan
2209       if (Perl_isnan(left) || Perl_isnan(right)) {
2210           SETs(&PL_sv_undef);
2211           RETURN;
2212        }
2213       value = (left > right) - (left < right);
2214 #else
2215       if (left == right)
2216         value = 0;
2217       else if (left < right)
2218         value = -1;
2219       else if (left > right)
2220         value = 1;
2221       else {
2222         SETs(&PL_sv_undef);
2223         RETURN;
2224       }
2225 #endif
2226       SETi(value);
2227       RETURN;
2228     }
2229 }
2230
2231 PP(pp_sle)
2232 {
2233     dVAR; dSP;
2234
2235     int amg_type = sle_amg;
2236     int multiplier = 1;
2237     int rhs = 1;
2238
2239     switch (PL_op->op_type) {
2240     case OP_SLT:
2241         amg_type = slt_amg;
2242         /* cmp < 0 */
2243         rhs = 0;
2244         break;
2245     case OP_SGT:
2246         amg_type = sgt_amg;
2247         /* cmp > 0 */
2248         multiplier = -1;
2249         rhs = 0;
2250         break;
2251     case OP_SGE:
2252         amg_type = sge_amg;
2253         /* cmp >= 0 */
2254         multiplier = -1;
2255         break;
2256     }
2257
2258     tryAMAGICbinSET_var(amg_type,0);
2259     {
2260       dPOPTOPssrl;
2261       const int cmp = (IN_LOCALE_RUNTIME
2262                  ? sv_cmp_locale(left, right)
2263                  : sv_cmp(left, right));
2264       SETs(boolSV(cmp * multiplier < rhs));
2265       RETURN;
2266     }
2267 }
2268
2269 PP(pp_seq)
2270 {
2271     dVAR; dSP; tryAMAGICbinSET(seq,0);
2272     {
2273       dPOPTOPssrl;
2274       SETs(boolSV(sv_eq(left, right)));
2275       RETURN;
2276     }
2277 }
2278
2279 PP(pp_sne)
2280 {
2281     dVAR; dSP; tryAMAGICbinSET(sne,0);
2282     {
2283       dPOPTOPssrl;
2284       SETs(boolSV(!sv_eq(left, right)));
2285       RETURN;
2286     }
2287 }
2288
2289 PP(pp_scmp)
2290 {
2291     dVAR; dSP; dTARGET;  tryAMAGICbin(scmp,0);
2292     {
2293       dPOPTOPssrl;
2294       const int cmp = (IN_LOCALE_RUNTIME
2295                  ? sv_cmp_locale(left, right)
2296                  : sv_cmp(left, right));
2297       SETi( cmp );
2298       RETURN;
2299     }
2300 }
2301
2302 PP(pp_bit_and)
2303 {
2304     dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2305     {
2306       dPOPTOPssrl;
2307       SvGETMAGIC(left);
2308       SvGETMAGIC(right);
2309       if (SvNIOKp(left) || SvNIOKp(right)) {
2310         if (PL_op->op_private & HINT_INTEGER) {
2311           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2312           SETi(i);
2313         }
2314         else {
2315           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2316           SETu(u);
2317         }
2318       }
2319       else {
2320         do_vop(PL_op->op_type, TARG, left, right);
2321         SETTARG;
2322       }
2323       RETURN;
2324     }
2325 }
2326
2327 PP(pp_bit_or)
2328 {
2329     dVAR; dSP; dATARGET;
2330     const int op_type = PL_op->op_type;
2331
2332     tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2333     {
2334       dPOPTOPssrl;
2335       SvGETMAGIC(left);
2336       SvGETMAGIC(right);
2337       if (SvNIOKp(left) || SvNIOKp(right)) {
2338         if (PL_op->op_private & HINT_INTEGER) {
2339           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2340           const IV r = SvIV_nomg(right);
2341           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2342           SETi(result);
2343         }
2344         else {
2345           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2346           const UV r = SvUV_nomg(right);
2347           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2348           SETu(result);
2349         }
2350       }
2351       else {
2352         do_vop(op_type, TARG, left, right);
2353         SETTARG;
2354       }
2355       RETURN;
2356     }
2357 }
2358
2359 PP(pp_negate)
2360 {
2361     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2362     {
2363         dTOPss;
2364         const int flags = SvFLAGS(sv);
2365         SvGETMAGIC(sv);
2366         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2367             /* It's publicly an integer, or privately an integer-not-float */
2368         oops_its_an_int:
2369             if (SvIsUV(sv)) {
2370                 if (SvIVX(sv) == IV_MIN) {
2371                     /* 2s complement assumption. */
2372                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2373                     RETURN;
2374                 }
2375                 else if (SvUVX(sv) <= IV_MAX) {
2376                     SETi(-SvIVX(sv));
2377                     RETURN;
2378                 }
2379             }
2380             else if (SvIVX(sv) != IV_MIN) {
2381                 SETi(-SvIVX(sv));
2382                 RETURN;
2383             }
2384 #ifdef PERL_PRESERVE_IVUV
2385             else {
2386                 SETu((UV)IV_MIN);
2387                 RETURN;
2388             }
2389 #endif
2390         }
2391         if (SvNIOKp(sv))
2392             SETn(-SvNV(sv));
2393         else if (SvPOKp(sv)) {
2394             STRLEN len;
2395             const char * const s = SvPV_const(sv, len);
2396             if (isIDFIRST(*s)) {
2397                 sv_setpvn(TARG, "-", 1);
2398                 sv_catsv(TARG, sv);
2399             }
2400             else if (*s == '+' || *s == '-') {
2401                 sv_setsv(TARG, sv);
2402                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2403             }
2404             else if (DO_UTF8(sv)) {
2405                 SvIV_please(sv);
2406                 if (SvIOK(sv))
2407                     goto oops_its_an_int;
2408                 if (SvNOK(sv))
2409                     sv_setnv(TARG, -SvNV(sv));
2410                 else {
2411                     sv_setpvn(TARG, "-", 1);
2412                     sv_catsv(TARG, sv);
2413                 }
2414             }
2415             else {
2416                 SvIV_please(sv);
2417                 if (SvIOK(sv))
2418                   goto oops_its_an_int;
2419                 sv_setnv(TARG, -SvNV(sv));
2420             }
2421             SETTARG;
2422         }
2423         else
2424             SETn(-SvNV(sv));
2425     }
2426     RETURN;
2427 }
2428
2429 PP(pp_not)
2430 {
2431     dVAR; dSP; tryAMAGICunSET(not);
2432     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2433     return NORMAL;
2434 }
2435
2436 PP(pp_complement)
2437 {
2438     dVAR; dSP; dTARGET; tryAMAGICun(compl);
2439     {
2440       dTOPss;
2441       SvGETMAGIC(sv);
2442       if (SvNIOKp(sv)) {
2443         if (PL_op->op_private & HINT_INTEGER) {
2444           const IV i = ~SvIV_nomg(sv);
2445           SETi(i);
2446         }
2447         else {
2448           const UV u = ~SvUV_nomg(sv);
2449           SETu(u);
2450         }
2451       }
2452       else {
2453         register U8 *tmps;
2454         register I32 anum;
2455         STRLEN len;
2456
2457         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2458         sv_setsv_nomg(TARG, sv);
2459         tmps = (U8*)SvPV_force(TARG, len);
2460         anum = len;
2461         if (SvUTF8(TARG)) {
2462           /* Calculate exact length, let's not estimate. */
2463           STRLEN targlen = 0;
2464           STRLEN l;
2465           UV nchar = 0;
2466           UV nwide = 0;
2467           U8 * const send = tmps + len;
2468           U8 * const origtmps = tmps;
2469           const UV utf8flags = UTF8_ALLOW_ANYUV;
2470
2471           while (tmps < send) {
2472             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2473             tmps += l;
2474             targlen += UNISKIP(~c);
2475             nchar++;
2476             if (c > 0xff)
2477                 nwide++;
2478           }
2479
2480           /* Now rewind strings and write them. */
2481           tmps = origtmps;
2482
2483           if (nwide) {
2484               U8 *result;
2485               U8 *p;
2486
2487               Newx(result, targlen + 1, U8);
2488               p = result;
2489               while (tmps < send) {
2490                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2491                   tmps += l;
2492                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2493               }
2494               *p = '\0';
2495               sv_usepvn_flags(TARG, (char*)result, targlen,
2496                               SV_HAS_TRAILING_NUL);
2497               SvUTF8_on(TARG);
2498           }
2499           else {
2500               U8 *result;
2501               U8 *p;
2502
2503               Newx(result, nchar + 1, U8);
2504               p = result;
2505               while (tmps < send) {
2506                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2507                   tmps += l;
2508                   *p++ = ~c;
2509               }
2510               *p = '\0';
2511               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2512               SvUTF8_off(TARG);
2513           }
2514           SETs(TARG);
2515           RETURN;
2516         }
2517 #ifdef LIBERAL
2518         {
2519             register long *tmpl;
2520             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2521                 *tmps = ~*tmps;
2522             tmpl = (long*)tmps;
2523             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2524                 *tmpl = ~*tmpl;
2525             tmps = (U8*)tmpl;
2526         }
2527 #endif
2528         for ( ; anum > 0; anum--, tmps++)
2529             *tmps = ~*tmps;
2530
2531         SETs(TARG);
2532       }
2533       RETURN;
2534     }
2535 }
2536
2537 /* integer versions of some of the above */
2538
2539 PP(pp_i_multiply)
2540 {
2541     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2542     {
2543       dPOPTOPiirl;
2544       SETi( left * right );
2545       RETURN;
2546     }
2547 }
2548
2549 PP(pp_i_divide)
2550 {
2551     IV num;
2552     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2553     {
2554       dPOPiv;
2555       if (value == 0)
2556           DIE(aTHX_ "Illegal division by zero");
2557       num = POPi;
2558
2559       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2560       if (value == -1)
2561           value = - num;
2562       else
2563           value = num / value;
2564       PUSHi( value );
2565       RETURN;
2566     }
2567 }
2568
2569 STATIC
2570 PP(pp_i_modulo_0)
2571 {
2572      /* This is the vanilla old i_modulo. */
2573      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2574      {
2575           dPOPTOPiirl;
2576           if (!right)
2577                DIE(aTHX_ "Illegal modulus zero");
2578           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2579           if (right == -1)
2580               SETi( 0 );
2581           else
2582               SETi( left % right );
2583           RETURN;
2584      }
2585 }
2586
2587 #if defined(__GLIBC__) && IVSIZE == 8
2588 STATIC
2589 PP(pp_i_modulo_1)
2590 {
2591      /* This is the i_modulo with the workaround for the _moddi3 bug
2592       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2593       * See below for pp_i_modulo. */
2594      dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2595      {
2596           dPOPTOPiirl;
2597           if (!right)
2598                DIE(aTHX_ "Illegal modulus zero");
2599           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2600           if (right == -1)
2601               SETi( 0 );
2602           else
2603               SETi( left % PERL_ABS(right) );
2604           RETURN;
2605      }
2606 }
2607 #endif
2608
2609 PP(pp_i_modulo)
2610 {
2611      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2612      {
2613           dPOPTOPiirl;
2614           if (!right)
2615                DIE(aTHX_ "Illegal modulus zero");
2616           /* The assumption is to use hereafter the old vanilla version... */
2617           PL_op->op_ppaddr =
2618                PL_ppaddr[OP_I_MODULO] =
2619                    Perl_pp_i_modulo_0;
2620           /* .. but if we have glibc, we might have a buggy _moddi3
2621            * (at least glicb 2.2.5 is known to have this bug), in other
2622            * words our integer modulus with negative quad as the second
2623            * argument might be broken.  Test for this and re-patch the
2624            * opcode dispatch table if that is the case, remembering to
2625            * also apply the workaround so that this first round works
2626            * right, too.  See [perl #9402] for more information. */
2627 #if defined(__GLIBC__) && IVSIZE == 8
2628           {
2629                IV l =   3;
2630                IV r = -10;
2631                /* Cannot do this check with inlined IV constants since
2632                 * that seems to work correctly even with the buggy glibc. */
2633                if (l % r == -3) {
2634                     /* Yikes, we have the bug.
2635                      * Patch in the workaround version. */
2636                     PL_op->op_ppaddr =
2637                          PL_ppaddr[OP_I_MODULO] =
2638                              &Perl_pp_i_modulo_1;
2639                     /* Make certain we work right this time, too. */
2640                     right = PERL_ABS(right);
2641                }
2642           }
2643 #endif
2644           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2645           if (right == -1)
2646               SETi( 0 );
2647           else
2648               SETi( left % right );
2649           RETURN;
2650      }
2651 }
2652
2653 PP(pp_i_add)
2654 {
2655     dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2656     {
2657       dPOPTOPiirl_ul;
2658       SETi( left + right );
2659       RETURN;
2660     }
2661 }
2662
2663 PP(pp_i_subtract)
2664 {
2665     dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2666     {
2667       dPOPTOPiirl_ul;
2668       SETi( left - right );
2669       RETURN;
2670     }
2671 }
2672
2673 PP(pp_i_lt)
2674 {
2675     dVAR; dSP; tryAMAGICbinSET(lt,0);
2676     {
2677       dPOPTOPiirl;
2678       SETs(boolSV(left < right));
2679       RETURN;
2680     }
2681 }
2682
2683 PP(pp_i_gt)
2684 {
2685     dVAR; dSP; tryAMAGICbinSET(gt,0);
2686     {
2687       dPOPTOPiirl;
2688       SETs(boolSV(left > right));
2689       RETURN;
2690     }
2691 }
2692
2693 PP(pp_i_le)
2694 {
2695     dVAR; dSP; tryAMAGICbinSET(le,0);
2696     {
2697       dPOPTOPiirl;
2698       SETs(boolSV(left <= right));
2699       RETURN;
2700     }
2701 }
2702
2703 PP(pp_i_ge)
2704 {
2705     dVAR; dSP; tryAMAGICbinSET(ge,0);
2706     {
2707       dPOPTOPiirl;
2708       SETs(boolSV(left >= right));
2709       RETURN;
2710     }
2711 }
2712
2713 PP(pp_i_eq)
2714 {
2715     dVAR; dSP; tryAMAGICbinSET(eq,0);
2716     {
2717       dPOPTOPiirl;
2718       SETs(boolSV(left == right));
2719       RETURN;
2720     }
2721 }
2722
2723 PP(pp_i_ne)
2724 {
2725     dVAR; dSP; tryAMAGICbinSET(ne,0);
2726     {
2727       dPOPTOPiirl;
2728       SETs(boolSV(left != right));
2729       RETURN;
2730     }
2731 }
2732
2733 PP(pp_i_ncmp)
2734 {
2735     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2736     {
2737       dPOPTOPiirl;
2738       I32 value;
2739
2740       if (left > right)
2741         value = 1;
2742       else if (left < right)
2743         value = -1;
2744       else
2745         value = 0;
2746       SETi(value);
2747       RETURN;
2748     }
2749 }
2750
2751 PP(pp_i_negate)
2752 {
2753     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2754     SETi(-TOPi);
2755     RETURN;
2756 }
2757
2758 /* High falutin' math. */
2759
2760 PP(pp_atan2)
2761 {
2762     dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2763     {
2764       dPOPTOPnnrl;
2765       SETn(Perl_atan2(left, right));
2766       RETURN;
2767     }
2768 }
2769
2770 PP(pp_sin)
2771 {
2772     dVAR; dSP; dTARGET;
2773     int amg_type = sin_amg;
2774     const char *neg_report = NULL;
2775     NV (*func)(NV) = Perl_sin;
2776     const int op_type = PL_op->op_type;
2777
2778     switch (op_type) {
2779     case OP_COS:
2780         amg_type = cos_amg;
2781         func = Perl_cos;
2782         break;
2783     case OP_EXP:
2784         amg_type = exp_amg;
2785         func = Perl_exp;
2786         break;
2787     case OP_LOG:
2788         amg_type = log_amg;
2789         func = Perl_log;
2790         neg_report = "log";
2791         break;
2792     case OP_SQRT:
2793         amg_type = sqrt_amg;
2794         func = Perl_sqrt;
2795         neg_report = "sqrt";
2796         break;
2797     }
2798
2799     tryAMAGICun_var(amg_type);
2800     {
2801       const NV value = POPn;
2802       if (neg_report) {
2803           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2804               SET_NUMERIC_STANDARD();
2805               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2806           }
2807       }
2808       XPUSHn(func(value));
2809       RETURN;
2810     }
2811 }
2812
2813 /* Support Configure command-line overrides for rand() functions.
2814    After 5.005, perhaps we should replace this by Configure support
2815    for drand48(), random(), or rand().  For 5.005, though, maintain
2816    compatibility by calling rand() but allow the user to override it.
2817    See INSTALL for details.  --Andy Dougherty  15 July 1998
2818 */
2819 /* Now it's after 5.005, and Configure supports drand48() and random(),
2820    in addition to rand().  So the overrides should not be needed any more.
2821    --Jarkko Hietaniemi  27 September 1998
2822  */
2823
2824 #ifndef HAS_DRAND48_PROTO
2825 extern double drand48 (void);
2826 #endif
2827
2828 PP(pp_rand)
2829 {
2830     dVAR; dSP; dTARGET;
2831     NV value;
2832     if (MAXARG < 1)
2833         value = 1.0;
2834     else
2835         value = POPn;
2836     if (value == 0.0)
2837         value = 1.0;
2838     if (!PL_srand_called) {
2839         (void)seedDrand01((Rand_seed_t)seed());
2840         PL_srand_called = TRUE;
2841     }
2842     value *= Drand01();
2843     XPUSHn(value);
2844     RETURN;
2845 }
2846
2847 PP(pp_srand)
2848 {
2849     dVAR; dSP;
2850     const UV anum = (MAXARG < 1) ? seed() : POPu;
2851     (void)seedDrand01((Rand_seed_t)anum);
2852     PL_srand_called = TRUE;
2853     EXTEND(SP, 1);
2854     RETPUSHYES;
2855 }
2856
2857 PP(pp_int)
2858 {
2859     dVAR; dSP; dTARGET; tryAMAGICun(int);
2860     {
2861       const IV iv = TOPi; /* attempt to convert to IV if possible. */
2862       /* XXX it's arguable that compiler casting to IV might be subtly
2863          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2864          else preferring IV has introduced a subtle behaviour change bug. OTOH
2865          relying on floating point to be accurate is a bug.  */
2866
2867       if (!SvOK(TOPs))
2868         SETu(0);
2869       else if (SvIOK(TOPs)) {
2870         if (SvIsUV(TOPs)) {
2871             const UV uv = TOPu;
2872             SETu(uv);
2873         } else
2874             SETi(iv);
2875       } else {
2876           const NV value = TOPn;
2877           if (value >= 0.0) {
2878               if (value < (NV)UV_MAX + 0.5) {
2879                   SETu(U_V(value));
2880               } else {
2881                   SETn(Perl_floor(value));
2882               }
2883           }
2884           else {
2885               if (value > (NV)IV_MIN - 0.5) {
2886                   SETi(I_V(value));
2887               } else {
2888                   SETn(Perl_ceil(value));
2889               }
2890           }
2891       }
2892     }
2893     RETURN;
2894 }
2895
2896 PP(pp_abs)
2897 {
2898     dVAR; dSP; dTARGET; tryAMAGICun(abs);
2899     {
2900       /* This will cache the NV value if string isn't actually integer  */
2901       const IV iv = TOPi;
2902
2903       if (!SvOK(TOPs))
2904         SETu(0);
2905       else if (SvIOK(TOPs)) {
2906         /* IVX is precise  */
2907         if (SvIsUV(TOPs)) {
2908           SETu(TOPu);   /* force it to be numeric only */
2909         } else {
2910           if (iv >= 0) {
2911             SETi(iv);
2912           } else {
2913             if (iv != IV_MIN) {
2914               SETi(-iv);
2915             } else {
2916               /* 2s complement assumption. Also, not really needed as
2917                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2918               SETu(IV_MIN);
2919             }
2920           }
2921         }
2922       } else{
2923         const NV value = TOPn;
2924         if (value < 0.0)
2925           SETn(-value);
2926         else
2927           SETn(value);
2928       }
2929     }
2930     RETURN;
2931 }
2932
2933 PP(pp_oct)
2934 {
2935     dVAR; dSP; dTARGET;
2936     const char *tmps;
2937     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2938     STRLEN len;
2939     NV result_nv;
2940     UV result_uv;
2941     SV* const sv = POPs;
2942
2943     tmps = (SvPV_const(sv, len));
2944     if (DO_UTF8(sv)) {
2945          /* If Unicode, try to downgrade
2946           * If not possible, croak. */
2947          SV* const tsv = sv_2mortal(newSVsv(sv));
2948
2949          SvUTF8_on(tsv);
2950          sv_utf8_downgrade(tsv, FALSE);
2951          tmps = SvPV_const(tsv, len);
2952     }
2953     if (PL_op->op_type == OP_HEX)
2954         goto hex;
2955
2956     while (*tmps && len && isSPACE(*tmps))
2957         tmps++, len--;
2958     if (*tmps == '0')
2959         tmps++, len--;
2960     if (*tmps == 'x') {
2961     hex:
2962         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2963     }
2964     else if (*tmps == 'b')
2965         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2966     else
2967         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2968
2969     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2970         XPUSHn(result_nv);
2971     }
2972     else {
2973         XPUSHu(result_uv);
2974     }
2975     RETURN;
2976 }
2977
2978 /* String stuff. */
2979
2980 PP(pp_length)
2981 {
2982     dVAR; dSP; dTARGET;
2983     SV * const sv = TOPs;
2984
2985     if (SvAMAGIC(sv)) {
2986         /* For an overloaded scalar, we can't know in advance if it's going to
2987            be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2988            cache the length. Maybe that should be a documented feature of it.
2989         */
2990         STRLEN len;
2991         const char *const p = SvPV_const(sv, len);
2992
2993         if (DO_UTF8(sv)) {
2994             SETi(utf8_length((U8*)p, (U8*)p + len));
2995         }
2996         else
2997             SETi(len);
2998
2999     }
3000     else if (DO_UTF8(sv))
3001         SETi(sv_len_utf8(sv));
3002     else
3003         SETi(sv_len(sv));
3004     RETURN;
3005 }
3006
3007 PP(pp_substr)
3008 {
3009     dVAR; dSP; dTARGET;
3010     SV *sv;
3011     I32 len = 0;
3012     STRLEN curlen;
3013     STRLEN utf8_curlen;
3014     I32 pos;
3015     I32 rem;
3016     I32 fail;
3017     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3018     const char *tmps;
3019     const I32 arybase = CopARYBASE_get(PL_curcop);
3020     SV *repl_sv = NULL;
3021     const char *repl = NULL;
3022     STRLEN repl_len;
3023     const int num_args = PL_op->op_private & 7;
3024     bool repl_need_utf8_upgrade = FALSE;
3025     bool repl_is_utf8 = FALSE;
3026
3027     SvTAINTED_off(TARG);                        /* decontaminate */
3028     SvUTF8_off(TARG);                           /* decontaminate */
3029     if (num_args > 2) {
3030         if (num_args > 3) {
3031             repl_sv = POPs;
3032             repl = SvPV_const(repl_sv, repl_len);
3033             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3034         }
3035         len = POPi;
3036     }
3037     pos = POPi;
3038     sv = POPs;
3039     PUTBACK;
3040     if (repl_sv) {
3041         if (repl_is_utf8) {
3042             if (!DO_UTF8(sv))
3043                 sv_utf8_upgrade(sv);
3044         }
3045         else if (DO_UTF8(sv))
3046             repl_need_utf8_upgrade = TRUE;
3047     }
3048     tmps = SvPV_const(sv, curlen);
3049     if (DO_UTF8(sv)) {
3050         utf8_curlen = sv_len_utf8(sv);
3051         if (utf8_curlen == curlen)
3052             utf8_curlen = 0;
3053         else
3054             curlen = utf8_curlen;
3055     }
3056     else
3057         utf8_curlen = 0;
3058
3059     if (pos >= arybase) {
3060         pos -= arybase;
3061         rem = curlen-pos;
3062         fail = rem;
3063         if (num_args > 2) {
3064             if (len < 0) {
3065                 rem += len;
3066                 if (rem < 0)
3067                     rem = 0;
3068             }
3069             else if (rem > len)
3070                      rem = len;
3071         }
3072     }
3073     else {
3074         pos += curlen;
3075         if (num_args < 3)
3076             rem = curlen;
3077         else if (len >= 0) {
3078             rem = pos+len;
3079             if (rem > (I32)curlen)
3080                 rem = curlen;
3081         }
3082         else {
3083             rem = curlen+len;
3084             if (rem < pos)
3085                 rem = pos;
3086         }
3087         if (pos < 0)
3088             pos = 0;
3089         fail = rem;
3090         rem -= pos;
3091     }
3092     if (fail < 0) {
3093         if (lvalue || repl)
3094             Perl_croak(aTHX_ "substr outside of string");
3095         if (ckWARN(WARN_SUBSTR))
3096             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3097         RETPUSHUNDEF;
3098     }
3099     else {
3100         const I32 upos = pos;
3101         const I32 urem = rem;
3102         if (utf8_curlen)
3103             sv_pos_u2b(sv, &pos, &rem);
3104         tmps += pos;
3105         /* we either return a PV or an LV. If the TARG hasn't been used
3106          * before, or is of that type, reuse it; otherwise use a mortal
3107          * instead. Note that LVs can have an extended lifetime, so also
3108          * dont reuse if refcount > 1 (bug #20933) */
3109         if (SvTYPE(TARG) > SVt_NULL) {
3110             if ( (SvTYPE(TARG) == SVt_PVLV)
3111                     ? (!lvalue || SvREFCNT(TARG) > 1)
3112                     : lvalue)
3113             {
3114                 TARG = sv_newmortal();
3115             }
3116         }
3117
3118         sv_setpvn(TARG, tmps, rem);
3119 #ifdef USE_LOCALE_COLLATE
3120         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3121 #endif
3122         if (utf8_curlen)
3123             SvUTF8_on(TARG);
3124         if (repl) {
3125             SV* repl_sv_copy = NULL;
3126
3127             if (repl_need_utf8_upgrade) {
3128                 repl_sv_copy = newSVsv(repl_sv);
3129                 sv_utf8_upgrade(repl_sv_copy);
3130                 repl = SvPV_const(repl_sv_copy, repl_len);
3131                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3132             }
3133             sv_insert(sv, pos, rem, repl, repl_len);
3134             if (repl_is_utf8)
3135                 SvUTF8_on(sv);
3136             if (repl_sv_copy)
3137                 SvREFCNT_dec(repl_sv_copy);
3138         }
3139         else if (lvalue) {              /* it's an lvalue! */
3140             if (!SvGMAGICAL(sv)) {
3141                 if (SvROK(sv)) {
3142                     SvPV_force_nolen(sv);
3143                     if (ckWARN(WARN_SUBSTR))
3144                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3145                                 "Attempt to use reference as lvalue in substr");
3146                 }
3147                 if (isGV_with_GP(sv))
3148                     SvPV_force_nolen(sv);
3149                 else if (SvOK(sv))      /* is it defined ? */
3150                     (void)SvPOK_only_UTF8(sv);
3151                 else
3152                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3153             }
3154
3155             if (SvTYPE(TARG) < SVt_PVLV) {
3156                 sv_upgrade(TARG, SVt_PVLV);
3157                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3158             }
3159
3160             LvTYPE(TARG) = 'x';
3161             if (LvTARG(TARG) != sv) {
3162                 if (LvTARG(TARG))
3163                     SvREFCNT_dec(LvTARG(TARG));
3164                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3165             }
3166             LvTARGOFF(TARG) = upos;
3167             LvTARGLEN(TARG) = urem;
3168         }
3169     }
3170     SPAGAIN;
3171     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3172     RETURN;
3173 }
3174
3175 PP(pp_vec)
3176 {
3177     dVAR; dSP; dTARGET;
3178     register const IV size   = POPi;
3179     register const IV offset = POPi;
3180     register SV * const src = POPs;
3181     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3182
3183     SvTAINTED_off(TARG);                /* decontaminate */
3184     if (lvalue) {                       /* it's an lvalue! */
3185         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3186             TARG = sv_newmortal();
3187         if (SvTYPE(TARG) < SVt_PVLV) {
3188             sv_upgrade(TARG, SVt_PVLV);
3189             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3190         }
3191         LvTYPE(TARG) = 'v';
3192         if (LvTARG(TARG) != src) {
3193             if (LvTARG(TARG))
3194                 SvREFCNT_dec(LvTARG(TARG));
3195             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3196         }
3197         LvTARGOFF(TARG) = offset;
3198         LvTARGLEN(TARG) = size;
3199     }
3200
3201     sv_setuv(TARG, do_vecget(src, offset, size));
3202     PUSHs(TARG);
3203     RETURN;
3204 }
3205
3206 PP(pp_index)
3207 {
3208     dVAR; dSP; dTARGET;
3209     SV *big;
3210     SV *little;
3211     SV *temp = NULL;
3212     STRLEN biglen;
3213     STRLEN llen = 0;
3214     I32 offset;
3215     I32 retval;
3216     const char *big_p;
3217     const char *little_p;
3218     const I32 arybase = CopARYBASE_get(PL_curcop);
3219     bool big_utf8;
3220     bool little_utf8;
3221     const bool is_index = PL_op->op_type == OP_INDEX;
3222
3223     if (MAXARG >= 3) {
3224         /* arybase is in characters, like offset, so combine prior to the
3225            UTF-8 to bytes calculation.  */
3226         offset = POPi - arybase;
3227     }
3228     little = POPs;
3229     big = POPs;
3230     big_p = SvPV_const(big, biglen);
3231     little_p = SvPV_const(little, llen);
3232
3233     big_utf8 = DO_UTF8(big);
3234     little_utf8 = DO_UTF8(little);
3235     if (big_utf8 ^ little_utf8) {
3236         /* One needs to be upgraded.  */
3237         if (little_utf8 && !PL_encoding) {
3238             /* Well, maybe instead we might be able to downgrade the small
3239                string?  */
3240             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3241                                                      &little_utf8);
3242             if (little_utf8) {
3243                 /* If the large string is ISO-8859-1, and it's not possible to
3244                    convert the small string to ISO-8859-1, then there is no
3245                    way that it could be found anywhere by index.  */
3246                 retval = -1;
3247                 goto fail;
3248             }
3249
3250             /* At this point, pv is a malloc()ed string. So donate it to temp
3251                to ensure it will get free()d  */
3252             little = temp = newSV(0);
3253             sv_usepvn(temp, pv, llen);
3254             little_p = SvPVX(little);
3255         } else {
3256             temp = little_utf8
3257                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3258
3259             if (PL_encoding) {
3260                 sv_recode_to_utf8(temp, PL_encoding);
3261             } else {
3262                 sv_utf8_upgrade(temp);
3263             }
3264             if (little_utf8) {
3265                 big = temp;
3266                 big_utf8 = TRUE;
3267                 big_p = SvPV_const(big, biglen);
3268             } else {
3269                 little = temp;
3270                 little_p = SvPV_const(little, llen);
3271             }
3272         }
3273     }
3274     if (SvGAMAGIC(big)) {
3275         /* Life just becomes a lot easier if I use a temporary here.
3276            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3277            will trigger magic and overloading again, as will fbm_instr()
3278         */
3279         big = sv_2mortal(newSVpvn(big_p, biglen));
3280         if (big_utf8)
3281             SvUTF8_on(big);
3282         big_p = SvPVX(big);
3283     }
3284     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3285         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3286            warn on undef, and we've already triggered a warning with the
3287            SvPV_const some lines above. We can't remove that, as we need to
3288            call some SvPV to trigger overloading early and find out if the
3289            string is UTF-8.
3290            This is all getting to messy. The API isn't quite clean enough,
3291            because data access has side effects.
3292         */
3293         little = sv_2mortal(newSVpvn(little_p, llen));
3294         if (little_utf8)
3295             SvUTF8_on(little);
3296         little_p = SvPVX(little);
3297     }
3298
3299     if (MAXARG < 3)
3300         offset = is_index ? 0 : biglen;
3301     else {
3302         if (big_utf8 && offset > 0)
3303             sv_pos_u2b(big, &offset, 0);
3304         if (!is_index)
3305             offset += llen;
3306     }
3307     if (offset < 0)
3308         offset = 0;
3309     else if (offset > (I32)biglen)
3310         offset = biglen;
3311     if (!(little_p = is_index
3312           ? fbm_instr((unsigned char*)big_p + offset,
3313                       (unsigned char*)big_p + biglen, little, 0)
3314           : rninstr(big_p,  big_p  + offset,
3315                     little_p, little_p + llen)))
3316         retval = -1;
3317     else {
3318         retval = little_p - big_p;
3319         if (retval > 0 && big_utf8)
3320             sv_pos_b2u(big, &retval);
3321     }
3322     if (temp)
3323         SvREFCNT_dec(temp);
3324  fail:
3325     PUSHi(retval + arybase);
3326     RETURN;
3327 }
3328
3329 PP(pp_sprintf)
3330 {
3331     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3332     if (SvTAINTED(MARK[1]))
3333         TAINT_PROPER("sprintf");
3334     do_sprintf(TARG, SP-MARK, MARK+1);
3335     TAINT_IF(SvTAINTED(TARG));
3336     SP = ORIGMARK;
3337     PUSHTARG;
3338     RETURN;
3339 }
3340
3341 PP(pp_ord)
3342 {
3343     dVAR; dSP; dTARGET;
3344
3345     SV *argsv = POPs;
3346     STRLEN len;
3347     const U8 *s = (U8*)SvPV_const(argsv, len);
3348
3349     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3350         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3351         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3352         argsv = tmpsv;
3353     }
3354
3355     XPUSHu(DO_UTF8(argsv) ?
3356            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3357            (*s & 0xff));
3358
3359     RETURN;
3360 }
3361
3362 PP(pp_chr)
3363 {
3364     dVAR; dSP; dTARGET;
3365     char *tmps;
3366     UV value;
3367
3368     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3369          ||
3370          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3371         if (IN_BYTES) {
3372             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3373         } else {
3374             (void) POPs; /* Ignore the argument value. */
3375             value = UNICODE_REPLACEMENT;
3376         }
3377     } else {
3378         value = POPu;
3379     }
3380
3381     SvUPGRADE(TARG,SVt_PV);
3382
3383     if (value > 255 && !IN_BYTES) {
3384         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3385         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3386         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3387         *tmps = '\0';
3388         (void)SvPOK_only(TARG);
3389         SvUTF8_on(TARG);
3390         XPUSHs(TARG);
3391         RETURN;
3392     }
3393
3394     SvGROW(TARG,2);
3395     SvCUR_set(TARG, 1);
3396     tmps = SvPVX(TARG);
3397     *tmps++ = (char)value;
3398     *tmps = '\0';
3399     (void)SvPOK_only(TARG);
3400
3401     if (PL_encoding && !IN_BYTES) {
3402         sv_recode_to_utf8(TARG, PL_encoding);
3403         tmps = SvPVX(TARG);
3404         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3405             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3406             SvGROW(TARG, 2);
3407             tmps = SvPVX(TARG);
3408             SvCUR_set(TARG, 1);
3409             *tmps++ = (char)value;
3410             *tmps = '\0';
3411             SvUTF8_off(TARG);
3412         }
3413     }
3414
3415     XPUSHs(TARG);
3416     RETURN;
3417 }
3418
3419 PP(pp_crypt)
3420 {
3421 #ifdef HAS_CRYPT
3422     dVAR; dSP; dTARGET;
3423     dPOPTOPssrl;
3424     STRLEN len;
3425     const char *tmps = SvPV_const(left, len);
3426
3427     if (DO_UTF8(left)) {
3428          /* If Unicode, try to downgrade.
3429           * If not possible, croak.
3430           * Yes, we made this up.  */
3431          SV* const tsv = sv_2mortal(newSVsv(left));
3432
3433          SvUTF8_on(tsv);
3434          sv_utf8_downgrade(tsv, FALSE);
3435          tmps = SvPV_const(tsv, len);
3436     }
3437 #   ifdef USE_ITHREADS
3438 #     ifdef HAS_CRYPT_R
3439     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3440       /* This should be threadsafe because in ithreads there is only
3441        * one thread per interpreter.  If this would not be true,
3442        * we would need a mutex to protect this malloc. */
3443         PL_reentrant_buffer->_crypt_struct_buffer =
3444           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3445 #if defined(__GLIBC__) || defined(__EMX__)
3446         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3447             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3448             /* work around glibc-2.2.5 bug */
3449             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3450         }
3451 #endif
3452     }
3453 #     endif /* HAS_CRYPT_R */
3454 #   endif /* USE_ITHREADS */
3455 #   ifdef FCRYPT
3456     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3457 #   else
3458     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3459 #   endif
3460     SETs(TARG);
3461     RETURN;
3462 #else
3463     DIE(aTHX_
3464       "The crypt() function is unimplemented due to excessive paranoia.");
3465 #endif
3466 }
3467
3468 PP(pp_ucfirst)
3469 {
3470     dVAR;
3471     dSP;
3472     SV *source = TOPs;
3473     STRLEN slen;
3474     STRLEN need;
3475     SV *dest;
3476     bool inplace = TRUE;
3477     bool doing_utf8;
3478     const int op_type = PL_op->op_type;
3479     const U8 *s;
3480     U8 *d;
3481     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3482     STRLEN ulen;
3483     STRLEN tculen;
3484
3485     SvGETMAGIC(source);
3486     if (SvOK(source)) {
3487         s = (const U8*)SvPV_nomg_const(source, slen);
3488     } else {
3489         s = (const U8*)"";
3490         slen = 0;
3491     }
3492
3493     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3494         doing_utf8 = TRUE;
3495         utf8_to_uvchr(s, &ulen);
3496         if (op_type == OP_UCFIRST) {
3497             toTITLE_utf8(s, tmpbuf, &tculen);
3498         } else {
3499             toLOWER_utf8(s, tmpbuf, &tculen);
3500         }
3501         /* If the two differ, we definately cannot do inplace.  */
3502         inplace = (ulen == tculen);
3503         need = slen + 1 - ulen + tculen;
3504     } else {
3505         doing_utf8 = FALSE;
3506         need = slen + 1;
3507     }
3508
3509     if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3510         /* We can convert in place.  */
3511
3512         dest = source;
3513         s = d = (U8*)SvPV_force_nomg(source, slen);
3514     } else {
3515         dTARGET;
3516
3517         dest = TARG;
3518
3519         SvUPGRADE(dest, SVt_PV);
3520         d = (U8*)SvGROW(dest, need);
3521         (void)SvPOK_only(dest);
3522
3523         SETs(dest);
3524
3525         inplace = FALSE;
3526     }
3527
3528     if (doing_utf8) {
3529         if(!inplace) {
3530             /* slen is the byte length of the whole SV.
3531              * ulen is the byte length of the original Unicode character
3532              * stored as UTF-8 at s.
3533              * tculen is the byte length of the freshly titlecased (or
3534              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3535              * We first set the result to be the titlecased (/lowercased)
3536              * character, and then append the rest of the SV data. */
3537             sv_setpvn(dest, (char*)tmpbuf, tculen);
3538             if (slen > ulen)
3539                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3540             SvUTF8_on(dest);
3541         }
3542         else {
3543             Copy(tmpbuf, d, tculen, U8);
3544             SvCUR_set(dest, need - 1);
3545         }
3546     }
3547     else {
3548         if (*s) {
3549             if (IN_LOCALE_RUNTIME) {
3550                 TAINT;
3551                 SvTAINTED_on(dest);
3552                 *d = (op_type == OP_UCFIRST)
3553                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3554             }
3555             else
3556                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3557         } else {
3558             /* See bug #39028  */
3559             *d = *s;
3560         }
3561
3562         if (SvUTF8(source))
3563             SvUTF8_on(dest);
3564
3565         if (!inplace) {
3566             /* This will copy the trailing NUL  */
3567             Copy(s + 1, d + 1, slen, U8);
3568             SvCUR_set(dest, need - 1);
3569         }
3570     }
3571     SvSETMAGIC(dest);
3572     RETURN;
3573 }
3574
3575 /* There's so much setup/teardown code common between uc and lc, I wonder if
3576    it would be worth merging the two, and just having a switch outside each
3577    of the three tight loops.  */
3578 PP(pp_uc)
3579 {
3580     dVAR;
3581     dSP;
3582     SV *source = TOPs;
3583     STRLEN len;
3584     STRLEN min;
3585     SV *dest;
3586     const U8 *s;
3587     U8 *d;
3588
3589     SvGETMAGIC(source);
3590
3591     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3592         && !DO_UTF8(source)) {
3593         /* We can convert in place.  */
3594
3595         dest = source;
3596         s = d = (U8*)SvPV_force_nomg(source, len);
3597         min = len + 1;
3598     } else {
3599         dTARGET;
3600
3601         dest = TARG;
3602
3603         /* The old implementation would copy source into TARG at this point.
3604            This had the side effect that if source was undef, TARG was now
3605            an undefined SV with PADTMP set, and they don't warn inside
3606            sv_2pv_flags(). However, we're now getting the PV direct from
3607            source, which doesn't have PADTMP set, so it would warn. Hence the
3608            little games.  */
3609
3610         if (SvOK(source)) {
3611             s = (const U8*)SvPV_nomg_const(source, len);
3612         } else {
3613             s = (const U8*)"";
3614             len = 0;
3615         }
3616         min = len + 1;
3617
3618         SvUPGRADE(dest, SVt_PV);
3619         d = (U8*)SvGROW(dest, min);
3620         (void)SvPOK_only(dest);
3621
3622         SETs(dest);
3623     }
3624
3625     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3626        to check DO_UTF8 again here.  */
3627
3628     if (DO_UTF8(source)) {
3629         const U8 *const send = s + len;
3630         U8 tmpbuf[UTF8_MAXBYTES+1];
3631
3632         while (s < send) {
3633             const STRLEN u = UTF8SKIP(s);
3634             STRLEN ulen;
3635
3636             toUPPER_utf8(s, tmpbuf, &ulen);
3637             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3638                 /* If the eventually required minimum size outgrows
3639                  * the available space, we need to grow. */
3640                 const UV o = d - (U8*)SvPVX_const(dest);
3641
3642                 /* If someone uppercases one million U+03B0s we SvGROW() one
3643                  * million times.  Or we could try guessing how much to
3644                  allocate without allocating too much.  Such is life. */
3645                 SvGROW(dest, min);
3646                 d = (U8*)SvPVX(dest) + o;
3647             }
3648             Copy(tmpbuf, d, ulen, U8);
3649             d += ulen;
3650             s += u;
3651         }
3652         SvUTF8_on(dest);
3653         *d = '\0';
3654         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3655     } else {
3656         if (len) {
3657             const U8 *const send = s + len;
3658             if (IN_LOCALE_RUNTIME) {
3659                 TAINT;
3660                 SvTAINTED_on(dest);
3661                 for (; s < send; d++, s++)
3662                     *d = toUPPER_LC(*s);
3663             }
3664             else {
3665                 for (; s < send; d++, s++)
3666                     *d = toUPPER(*s);
3667             }
3668         }
3669         if (source != dest) {
3670             *d = '\0';
3671             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3672         }
3673     }
3674     SvSETMAGIC(dest);
3675     RETURN;
3676 }
3677
3678 PP(pp_lc)
3679 {
3680     dVAR;
3681     dSP;
3682     SV *source = TOPs;
3683     STRLEN len;
3684     STRLEN min;
3685     SV *dest;
3686     const U8 *s;
3687     U8 *d;
3688
3689     SvGETMAGIC(source);
3690
3691     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3692         && !DO_UTF8(source)) {
3693         /* We can convert in place.  */
3694
3695         dest = source;
3696         s = d = (U8*)SvPV_force_nomg(source, len);
3697         min = len + 1;
3698     } else {
3699         dTARGET;
3700
3701         dest = TARG;
3702
3703         /* The old implementation would copy source into TARG at this point.
3704            This had the side effect that if source was undef, TARG was now
3705            an undefined SV with PADTMP set, and they don't warn inside
3706            sv_2pv_flags(). However, we're now getting the PV direct from
3707            source, which doesn't have PADTMP set, so it would warn. Hence the
3708            little games.  */
3709
3710         if (SvOK(source)) {
3711             s = (const U8*)SvPV_nomg_const(source, len);
3712         } else {
3713             s = (const U8*)"";
3714             len = 0;
3715         }
3716         min = len + 1;
3717
3718         SvUPGRADE(dest, SVt_PV);
3719         d = (U8*)SvGROW(dest, min);
3720         (void)SvPOK_only(dest);
3721
3722         SETs(dest);
3723     }
3724
3725     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3726        to check DO_UTF8 again here.  */
3727
3728     if (DO_UTF8(source)) {
3729         const U8 *const send = s + len;
3730         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3731
3732         while (s < send) {
3733             const STRLEN u = UTF8SKIP(s);
3734             STRLEN ulen;
3735             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3736
3737 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3738             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3739                 NOOP;
3740                 /*
3741                  * Now if the sigma is NOT followed by
3742                  * /$ignorable_sequence$cased_letter/;
3743                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3744                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3745                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3746                  * then it should be mapped to 0x03C2,
3747                  * (GREEK SMALL LETTER FINAL SIGMA),
3748                  * instead of staying 0x03A3.
3749                  * "should be": in other words, this is not implemented yet.
3750                  * See lib/unicore/SpecialCasing.txt.
3751                  */
3752             }
3753             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3754                 /* If the eventually required minimum size outgrows
3755                  * the available space, we need to grow. */
3756                 const UV o = d - (U8*)SvPVX_const(dest);
3757
3758                 /* If someone lowercases one million U+0130s we SvGROW() one
3759                  * million times.  Or we could try guessing how much to
3760                  allocate without allocating too much.  Such is life. */
3761                 SvGROW(dest, min);
3762                 d = (U8*)SvPVX(dest) + o;
3763             }
3764             Copy(tmpbuf, d, ulen, U8);
3765             d += ulen;
3766             s += u;
3767         }
3768         SvUTF8_on(dest);
3769         *d = '\0';
3770         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3771     } else {
3772         if (len) {
3773             const U8 *const send = s + len;
3774             if (IN_LOCALE_RUNTIME) {
3775                 TAINT;
3776                 SvTAINTED_on(dest);
3777                 for (; s < send; d++, s++)
3778                     *d = toLOWER_LC(*s);
3779             }
3780             else {
3781                 for (; s < send; d++, s++)
3782                     *d = toLOWER(*s);
3783             }
3784         }
3785         if (source != dest) {
3786             *d = '\0';
3787             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3788         }
3789     }
3790     SvSETMAGIC(dest);
3791     RETURN;
3792 }
3793
3794 PP(pp_quotemeta)
3795 {
3796     dVAR; dSP; dTARGET;
3797     SV * const sv = TOPs;
3798     STRLEN len;
3799     register const char *s = SvPV_const(sv,len);
3800
3801     SvUTF8_off(TARG);                           /* decontaminate */
3802     if (len) {
3803         register char *d;
3804         SvUPGRADE(TARG, SVt_PV);
3805         SvGROW(TARG, (len * 2) + 1);
3806         d = SvPVX(TARG);
3807         if (DO_UTF8(sv)) {
3808             while (len) {
3809                 if (UTF8_IS_CONTINUED(*s)) {
3810                     STRLEN ulen = UTF8SKIP(s);
3811                     if (ulen > len)
3812                         ulen = len;
3813                     len -= ulen;
3814                     while (ulen--)
3815                         *d++ = *s++;
3816                 }
3817                 else {
3818                     if (!isALNUM(*s))
3819                         *d++ = '\\';
3820                     *d++ = *s++;
3821                     len--;
3822                 }
3823             }
3824             SvUTF8_on(TARG);
3825         }
3826         else {
3827             while (len--) {
3828                 if (!isALNUM(*s))
3829                     *d++ = '\\';
3830                 *d++ = *s++;
3831             }
3832         }
3833         *d = '\0';
3834         SvCUR_set(TARG, d - SvPVX_const(TARG));
3835         (void)SvPOK_only_UTF8(TARG);
3836     }
3837     else
3838         sv_setpvn(TARG, s, len);
3839     SETs(TARG);
3840     if (SvSMAGICAL(TARG))
3841         mg_set(TARG);
3842     RETURN;
3843 }
3844
3845 /* Arrays. */
3846
3847 PP(pp_aslice)
3848 {
3849     dVAR; dSP; dMARK; dORIGMARK;
3850     register AV* const av = (AV*)POPs;
3851     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3852
3853     if (SvTYPE(av) == SVt_PVAV) {
3854         const I32 arybase = CopARYBASE_get(PL_curcop);
3855         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3856             register SV **svp;
3857             I32 max = -1;
3858             for (svp = MARK + 1; svp <= SP; svp++) {
3859                 const I32 elem = SvIVx(*svp);
3860                 if (elem > max)
3861                     max = elem;
3862             }
3863             if (max > AvMAX(av))
3864                 av_extend(av, max);
3865         }
3866         while (++MARK <= SP) {
3867             register SV **svp;
3868             I32 elem = SvIVx(*MARK);
3869
3870             if (elem > 0)
3871                 elem -= arybase;
3872             svp = av_fetch(av, elem, lval);
3873             if (lval) {
3874                 if (!svp || *svp == &PL_sv_undef)
3875                     DIE(aTHX_ PL_no_aelem, elem);
3876                 if (PL_op->op_private & OPpLVAL_INTRO)
3877                     save_aelem(av, elem, svp);
3878             }
3879             *MARK = svp ? *svp : &PL_sv_undef;
3880         }
3881     }
3882     if (GIMME != G_ARRAY) {
3883         MARK = ORIGMARK;
3884         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3885         SP = MARK;
3886     }
3887     RETURN;
3888 }
3889
3890 /* Associative arrays. */
3891
3892 PP(pp_each)
3893 {
3894     dVAR;
3895     dSP;
3896     HV * hash = (HV*)POPs;
3897     HE *entry;
3898     const I32 gimme = GIMME_V;
3899
3900     PUTBACK;
3901     /* might clobber stack_sp */
3902     entry = hv_iternext(hash);
3903     SPAGAIN;
3904
3905     EXTEND(SP, 2);
3906     if (entry) {
3907         SV* const sv = hv_iterkeysv(entry);
3908         PUSHs(sv);      /* won't clobber stack_sp */
3909         if (gimme == G_ARRAY) {
3910             SV *val;
3911             PUTBACK;
3912             /* might clobber stack_sp */
3913             val = hv_iterval(hash, entry);
3914             SPAGAIN;
3915             PUSHs(val);
3916         }
3917     }
3918     else if (gimme == G_SCALAR)
3919         RETPUSHUNDEF;
3920
3921     RETURN;
3922 }
3923
3924 PP(pp_delete)
3925 {
3926     dVAR;
3927     dSP;
3928     const I32 gimme = GIMME_V;
3929     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3930
3931     if (PL_op->op_private & OPpSLICE) {
3932         dMARK; dORIGMARK;
3933         HV * const hv = (HV*)POPs;
3934         const U32 hvtype = SvTYPE(hv);
3935         if (hvtype == SVt_PVHV) {                       /* hash element */
3936             while (++MARK <= SP) {
3937                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3938                 *MARK = sv ? sv : &PL_sv_undef;
3939             }
3940         }
3941         else if (hvtype == SVt_PVAV) {                  /* array element */
3942             if (PL_op->op_flags & OPf_SPECIAL) {
3943                 while (++MARK <= SP) {
3944                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3945                     *MARK = sv ? sv : &PL_sv_undef;
3946                 }
3947             }
3948         }
3949         else
3950             DIE(aTHX_ "Not a HASH reference");
3951         if (discard)
3952             SP = ORIGMARK;
3953         else if (gimme == G_SCALAR) {
3954             MARK = ORIGMARK;
3955             if (SP > MARK)
3956                 *++MARK = *SP;
3957             else
3958                 *++MARK = &PL_sv_undef;
3959             SP = MARK;
3960         }
3961     }
3962     else {
3963         SV *keysv = POPs;
3964         HV * const hv = (HV*)POPs;
3965         SV *sv;
3966         if (SvTYPE(hv) == SVt_PVHV)
3967             sv = hv_delete_ent(hv, keysv, discard, 0);
3968         else if (SvTYPE(hv) == SVt_PVAV) {
3969             if (PL_op->op_flags & OPf_SPECIAL)
3970                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3971             else
3972                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3973         }
3974         else
3975             DIE(aTHX_ "Not a HASH reference");
3976         if (!sv)
3977             sv = &PL_sv_undef;
3978         if (!discard)
3979             PUSHs(sv);
3980     }
3981     RETURN;
3982 }
3983
3984 PP(pp_exists)
3985 {
3986     dVAR;
3987     dSP;
3988     SV *tmpsv;
3989     HV *hv;
3990
3991     if (PL_op->op_private & OPpEXISTS_SUB) {
3992         GV *gv;
3993         SV * const sv = POPs;
3994         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3995         if (cv)
3996             RETPUSHYES;
3997         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3998             RETPUSHYES;
3999         RETPUSHNO;
4000     }
4001     tmpsv = POPs;
4002     hv = (HV*)POPs;
4003     if (SvTYPE(hv) == SVt_PVHV) {
4004         if (hv_exists_ent(hv, tmpsv, 0))
4005             RETPUSHYES;
4006     }
4007     else if (SvTYPE(hv) == SVt_PVAV) {
4008         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4009             if (av_exists((AV*)hv, SvIV(tmpsv)))
4010                 RETPUSHYES;
4011         }
4012     }
4013     else {
4014         DIE(aTHX_ "Not a HASH reference");
4015     }
4016     RETPUSHNO;
4017 }
4018
4019 PP(pp_hslice)
4020 {
4021     dVAR; dSP; dMARK; dORIGMARK;
4022     register HV * const hv = (HV*)POPs;
4023     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4024     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4025     bool other_magic = FALSE;
4026
4027     if (localizing) {
4028         MAGIC *mg;
4029         HV *stash;
4030
4031         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4032             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4033              /* Try to preserve the existenceness of a tied hash
4034               * element by using EXISTS and DELETE if possible.
4035               * Fallback to FETCH and STORE otherwise */
4036              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4037              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4038              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4039     }
4040
4041     while (++MARK <= SP) {
4042         SV * const keysv = *MARK;
4043         SV **svp;
4044         HE *he;
4045         bool preeminent = FALSE;
4046
4047         if (localizing) {
4048             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4049                 hv_exists_ent(hv, keysv, 0);
4050         }
4051
4052         he = hv_fetch_ent(hv, keysv, lval, 0);
4053         svp = he ? &HeVAL(he) : 0;
4054
4055         if (lval) {
4056             if (!svp || *svp == &PL_sv_undef) {
4057                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4058             }
4059             if (localizing) {
4060                 if (HvNAME_get(hv) && isGV(*svp))
4061                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4062                 else {
4063                     if (preeminent)
4064                         save_helem(hv, keysv, svp);
4065                     else {
4066                         STRLEN keylen;
4067                         const char * const key = SvPV_const(keysv, keylen);
4068                         SAVEDELETE(hv, savepvn(key,keylen),
4069                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4070                     }
4071                 }
4072             }
4073         }
4074         *MARK = svp ? *svp : &PL_sv_undef;
4075     }
4076     if (GIMME != G_ARRAY) {
4077         MARK = ORIGMARK;
4078         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4079         SP = MARK;
4080     }
4081     RETURN;
4082 }
4083
4084 /* List operators. */
4085
4086 PP(pp_list)
4087 {
4088     dVAR; dSP; dMARK;
4089     if (GIMME != G_ARRAY) {
4090         if (++MARK <= SP)
4091             *MARK = *SP;                /* unwanted list, return last item */
4092         else
4093             *MARK = &PL_sv_undef;
4094         SP = MARK;
4095     }
4096     RETURN;
4097 }
4098
4099 PP(pp_lslice)
4100 {
4101     dVAR;
4102     dSP;
4103     SV ** const lastrelem = PL_stack_sp;
4104     SV ** const lastlelem = PL_stack_base + POPMARK;
4105     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4106     register SV ** const firstrelem = lastlelem + 1;
4107     const I32 arybase = CopARYBASE_get(PL_curcop);
4108     I32 is_something_there = FALSE;
4109
4110     register const I32 max = lastrelem - lastlelem;
4111     register SV **lelem;
4112
4113     if (GIMME != G_ARRAY) {
4114         I32 ix = SvIVx(*lastlelem);
4115         if (ix < 0)
4116             ix += max;
4117         else
4118             ix -= arybase;
4119         if (ix < 0 || ix >= max)
4120             *firstlelem = &PL_sv_undef;
4121         else
4122             *firstlelem = firstrelem[ix];
4123         SP = firstlelem;
4124         RETURN;
4125     }
4126
4127     if (max == 0) {
4128         SP = firstlelem - 1;
4129         RETURN;
4130     }
4131
4132     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4133         I32 ix = SvIVx(*lelem);
4134         if (ix < 0)
4135             ix += max;
4136         else
4137             ix -= arybase;
4138         if (ix < 0 || ix >= max)
4139             *lelem = &PL_sv_undef;
4140         else {
4141             is_something_there = TRUE;
4142             if (!(*lelem = firstrelem[ix]))
4143                 *lelem = &PL_sv_undef;
4144         }
4145     }
4146     if (is_something_there)
4147         SP = lastlelem;
4148     else
4149         SP = firstlelem - 1;
4150     RETURN;
4151 }
4152
4153 PP(pp_anonlist)
4154 {
4155     dVAR; dSP; dMARK; dORIGMARK;
4156     const I32 items = SP - MARK;
4157     SV * const av = (SV *) av_make(items, MARK+1);
4158     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4159     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4160                       ? newRV_noinc(av) : av));
4161     RETURN;
4162 }
4163
4164 PP(pp_anonhash)
4165 {
4166     dVAR; dSP; dMARK; dORIGMARK;
4167     HV* const hv = newHV();
4168
4169     while (MARK < SP) {
4170         SV * const key = *++MARK;
4171         SV * const val = newSV(0);
4172         if (MARK < SP)
4173             sv_setsv(val, *++MARK);
4174         else if (ckWARN(WARN_MISC))
4175             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4176         (void)hv_store_ent(hv,key,val,0);
4177     }
4178     SP = ORIGMARK;
4179     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4180                       ? newRV_noinc((SV*) hv) : (SV*)hv));
4181     RETURN;
4182 }
4183
4184 PP(pp_splice)
4185 {
4186     dVAR; dSP; dMARK; dORIGMARK;
4187     register AV *ary = (AV*)*++MARK;
4188     register SV **src;
4189     register SV **dst;
4190     register I32 i;
4191     register I32 offset;
4192     register I32 length;
4193     I32 newlen;
4194     I32 after;
4195     I32 diff;
4196     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4197
4198     if (mg) {
4199         *MARK-- = SvTIED_obj((SV*)ary, mg);
4200         PUSHMARK(MARK);
4201         PUTBACK;
4202         ENTER;
4203         call_method("SPLICE",GIMME_V);
4204         LEAVE;
4205         SPAGAIN;
4206         RETURN;
4207     }
4208
4209     SP++;
4210
4211     if (++MARK < SP) {
4212         offset = i = SvIVx(*MARK);
4213         if (offset < 0)
4214             offset += AvFILLp(ary) + 1;
4215         else
4216             offset -= CopARYBASE_get(PL_curcop);
4217         if (offset < 0)
4218             DIE(aTHX_ PL_no_aelem, i);
4219         if (++MARK < SP) {
4220             length = SvIVx(*MARK++);
4221             if (length < 0) {
4222                 length += AvFILLp(ary) - offset + 1;
4223                 if (length < 0)
4224                     length = 0;
4225             }
4226         }
4227         else
4228             length = AvMAX(ary) + 1;            /* close enough to infinity */
4229     }
4230     else {
4231         offset = 0;
4232         length = AvMAX(ary) + 1;
4233     }
4234     if (offset > AvFILLp(ary) + 1) {
4235         if (ckWARN(WARN_MISC))
4236             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4237         offset = AvFILLp(ary) + 1;
4238     }
4239     after = AvFILLp(ary) + 1 - (offset + length);
4240     if (after < 0) {                            /* not that much array */
4241         length += after;                        /* offset+length now in array */
4242         after = 0;
4243         if (!AvALLOC(ary))
4244             av_extend(ary, 0);
4245     }
4246
4247     /* At this point, MARK .. SP-1 is our new LIST */
4248
4249     newlen = SP - MARK;
4250     diff = newlen - length;
4251     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4252         av_reify(ary);
4253
4254     /* make new elements SVs now: avoid problems if they're from the array */
4255     for (dst = MARK, i = newlen; i; i--) {
4256         SV * const h = *dst;
4257         *dst++ = newSVsv(h);
4258     }
4259
4260     if (diff < 0) {                             /* shrinking the area */
4261         SV **tmparyval = NULL;
4262         if (newlen) {
4263             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4264             Copy(MARK, tmparyval, newlen, SV*);
4265         }
4266
4267         MARK = ORIGMARK + 1;
4268         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4269             MEXTEND(MARK, length);
4270             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4271             if (AvREAL(ary)) {
4272                 EXTEND_MORTAL(length);
4273                 for (i = length, dst = MARK; i; i--) {
4274                     sv_2mortal(*dst);   /* free them eventualy */
4275                     dst++;
4276                 }
4277             }
4278             MARK += length - 1;
4279         }
4280         else {
4281             *MARK = AvARRAY(ary)[offset+length-1];
4282             if (AvREAL(ary)) {
4283                 sv_2mortal(*MARK);
4284                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4285                     SvREFCNT_dec(*dst++);       /* free them now */
4286             }
4287         }
4288         AvFILLp(ary) += diff;
4289
4290         /* pull up or down? */
4291
4292         if (offset < after) {                   /* easier to pull up */
4293             if (offset) {                       /* esp. if nothing to pull */
4294                 src = &AvARRAY(ary)[offset-1];
4295                 dst = src - diff;               /* diff is negative */
4296                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4297                     *dst-- = *src--;
4298             }
4299             dst = AvARRAY(ary);
4300             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4301             AvMAX(ary) += diff;
4302         }
4303         else {
4304             if (after) {                        /* anything to pull down? */
4305                 src = AvARRAY(ary) + offset + length;
4306                 dst = src + diff;               /* diff is negative */
4307                 Move(src, dst, after, SV*);
4308             }
4309             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4310                                                 /* avoid later double free */
4311         }
4312         i = -diff;
4313         while (i)
4314             dst[--i] = &PL_sv_undef;
4315
4316         if (newlen) {
4317             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4318             Safefree(tmparyval);
4319         }
4320     }
4321     else {                                      /* no, expanding (or same) */
4322         SV** tmparyval = NULL;
4323         if (length) {
4324             Newx(tmparyval, length, SV*);       /* so remember deletion */
4325             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4326         }
4327
4328         if (diff > 0) {                         /* expanding */
4329             /* push up or down? */
4330             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4331                 if (offset) {
4332                     src = AvARRAY(ary);
4333                     dst = src - diff;
4334                     Move(src, dst, offset, SV*);
4335                 }
4336                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4337                 AvMAX(ary) += diff;
4338                 AvFILLp(ary) += diff;
4339             }
4340             else {
4341                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4342                     av_extend(ary, AvFILLp(ary) + diff);
4343                 AvFILLp(ary) += diff;
4344
4345                 if (after) {
4346                     dst = AvARRAY(ary) + AvFILLp(ary);
4347                     src = dst - diff;
4348                     for (i = after; i; i--) {
4349                         *dst-- = *src--;
4350                     }
4351                 }
4352             }
4353         }
4354
4355         if (newlen) {
4356             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4357         }
4358
4359         MARK = ORIGMARK + 1;
4360         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4361             if (length) {
4362                 Copy(tmparyval, MARK, length, SV*);
4363                 if (AvREAL(ary)) {
4364                     EXTEND_MORTAL(length);
4365                     for (i = length, dst = MARK; i; i--) {
4366                         sv_2mortal(*dst);       /* free them eventualy */
4367                         dst++;
4368                     }
4369                 }
4370             }
4371             MARK += length - 1;
4372         }
4373         else if (length--) {
4374             *MARK = tmparyval[length];
4375             if (AvREAL(ary)) {
4376                 sv_2mortal(*MARK);
4377                 while (length-- > 0)
4378                     SvREFCNT_dec(tmparyval[length]);
4379             }
4380         }
4381         else
4382             *MARK = &PL_sv_undef;
4383         Safefree(tmparyval);
4384     }
4385     SP = MARK;
4386     RETURN;
4387 }
4388
4389 PP(pp_push)
4390 {
4391     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4392     register AV * const ary = (AV*)*++MARK;
4393     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4394
4395     if (mg) {
4396         *MARK-- = SvTIED_obj((SV*)ary, mg);
4397         PUSHMARK(MARK);
4398         PUTBACK;
4399         ENTER;
4400         call_method("PUSH",G_SCALAR|G_DISCARD);
4401         LEAVE;
4402         SPAGAIN;
4403         SP = ORIGMARK;
4404         PUSHi( AvFILL(ary) + 1 );
4405     }
4406     else {
4407         for (++MARK; MARK <= SP; MARK++) {
4408             SV * const sv = newSV(0);
4409             if (*MARK)
4410                 sv_setsv(sv, *MARK);
4411             av_store(ary, AvFILLp(ary)+1, sv);
4412         }
4413         SP = ORIGMARK;
4414         PUSHi( AvFILLp(ary) + 1 );
4415     }
4416     RETURN;
4417 }
4418
4419 PP(pp_shift)
4420 {
4421     dVAR;
4422     dSP;
4423     AV * const av = (AV*)POPs;
4424     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4425     EXTEND(SP, 1);
4426     assert (sv);
4427     if (AvREAL(av))
4428         (void)sv_2mortal(sv);
4429     PUSHs(sv);
4430     RETURN;
4431 }
4432
4433 PP(pp_unshift)
4434 {
4435     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4436     register AV *ary = (AV*)*++MARK;
4437     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4438
4439     if (mg) {
4440         *MARK-- = SvTIED_obj((SV*)ary, mg);
4441         PUSHMARK(MARK);
4442         PUTBACK;
4443         ENTER;
4444         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4445         LEAVE;
4446         SPAGAIN;
4447     }
4448     else {
4449         register I32 i = 0;
4450         av_unshift(ary, SP - MARK);
4451         while (MARK < SP) {
4452             SV * const sv = newSVsv(*++MARK);
4453             (void)av_store(ary, i++, sv);
4454         }
4455     }
4456     SP = ORIGMARK;
4457     PUSHi( AvFILL(ary) + 1 );
4458     RETURN;
4459 }
4460
4461 PP(pp_reverse)
4462 {
4463     dVAR; dSP; dMARK;
4464     SV ** const oldsp = SP;
4465
4466     if (GIMME == G_ARRAY) {
4467         MARK++;
4468         while (MARK < SP) {
4469             register SV * const tmp = *MARK;
4470             *MARK++ = *SP;
4471             *SP-- = tmp;
4472         }
4473         /* safe as long as stack cannot get extended in the above */
4474         SP = oldsp;
4475     }
4476     else {
4477         register char *up;
4478         register char *down;
4479         register I32 tmp;
4480         dTARGET;
4481         STRLEN len;
4482         PADOFFSET padoff_du;
4483
4484         SvUTF8_off(TARG);                               /* decontaminate */
4485         if (SP - MARK > 1)
4486             do_join(TARG, &PL_sv_no, MARK, SP);
4487         else
4488             sv_setsv(TARG, (SP > MARK)
4489                     ? *SP
4490                     : (padoff_du = find_rundefsvoffset(),
4491                         (padoff_du == NOT_IN_PAD
4492                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4493                         ? DEFSV : PAD_SVl(padoff_du)));
4494         up = SvPV_force(TARG, len);
4495         if (len > 1) {
4496             if (DO_UTF8(TARG)) {        /* first reverse each character */
4497                 U8* s = (U8*)SvPVX(TARG);
4498                 const U8* send = (U8*)(s + len);
4499                 while (s < send) {
4500                     if (UTF8_IS_INVARIANT(*s)) {
4501                         s++;
4502                         continue;
4503                     }
4504                     else {
4505                         if (!utf8_to_uvchr(s, 0))
4506                             break;
4507                         up = (char*)s;
4508                         s += UTF8SKIP(s);
4509                         down = (char*)(s - 1);
4510                         /* reverse this character */
4511                         while (down > up) {
4512                             tmp = *up;
4513                             *up++ = *down;
4514                             *down-- = (char)tmp;
4515                         }
4516                     }
4517                 }
4518                 up = SvPVX(TARG);
4519             }
4520             down = SvPVX(TARG) + len - 1;
4521             while (down > up) {
4522                 tmp = *up;
4523                 *up++ = *down;
4524                 *down-- = (char)tmp;
4525             }
4526             (void)SvPOK_only_UTF8(TARG);
4527         }
4528         SP = MARK + 1;
4529         SETTARG;
4530     }
4531     RETURN;
4532 }
4533
4534 PP(pp_split)
4535 {
4536     dVAR; dSP; dTARG;
4537     AV *ary;
4538     register IV limit = POPi;                   /* note, negative is forever */
4539     SV * const sv = POPs;
4540     STRLEN len;
4541     register const char *s = SvPV_const(sv, len);
4542     const bool do_utf8 = DO_UTF8(sv);
4543     const char *strend = s + len;
4544     register PMOP *pm;
4545     register REGEXP *rx;
4546     register SV *dstr;
4547     register const char *m;
4548     I32 iters = 0;
4549     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4550     I32 maxiters = slen + 10;
4551     const char *orig;
4552     const I32 origlimit = limit;
4553     I32 realarray = 0;
4554     I32 base;
4555     const I32 gimme = GIMME_V;
4556     const I32 oldsave = PL_savestack_ix;
4557     I32 make_mortal = 1;
4558     bool multiline = 0;
4559     MAGIC *mg = NULL;
4560
4561 #ifdef DEBUGGING
4562     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4563 #else
4564     pm = (PMOP*)POPs;
4565 #endif
4566     if (!pm || !s)
4567         DIE(aTHX_ "panic: pp_split");
4568     rx = PM_GETRE(pm);
4569
4570     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4571              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4572
4573     RX_MATCH_UTF8_set(rx, do_utf8);
4574
4575     if (pm->op_pmreplroot) {
4576 #ifdef USE_ITHREADS
4577         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4578 #else
4579         ary = GvAVn((GV*)pm->op_pmreplroot);
4580 #endif
4581     }
4582     else if (gimme != G_ARRAY)
4583         ary = GvAVn(PL_defgv);
4584     else
4585         ary = NULL;
4586     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4587         realarray = 1;
4588         PUTBACK;
4589         av_extend(ary,0);
4590         av_clear(ary);
4591         SPAGAIN;
4592         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4593             PUSHMARK(SP);
4594             XPUSHs(SvTIED_obj((SV*)ary, mg));
4595         }
4596         else {
4597             if (!AvREAL(ary)) {
4598                 I32 i;
4599                 AvREAL_on(ary);
4600                 AvREIFY_off(ary);
4601                 for (i = AvFILLp(ary); i >= 0; i--)
4602                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4603             }
4604             /* temporarily switch stacks */
4605             SAVESWITCHSTACK(PL_curstack, ary);
4606             make_mortal = 0;
4607         }
4608     }
4609     base = SP - PL_stack_base;
4610     orig = s;
4611     if (pm->op_pmflags & PMf_SKIPWHITE) {
4612         if (do_utf8) {
4613             while (*s == ' ' || is_utf8_space((U8*)s))
4614                 s += UTF8SKIP(s);
4615         }
4616         else if (pm->op_pmflags & PMf_LOCALE) {
4617             while (isSPACE_LC(*s))
4618                 s++;
4619         }
4620         else {
4621             while (isSPACE(*s))
4622                 s++;
4623         }
4624     }
4625     if (pm->op_pmflags & PMf_MULTILINE) {
4626         multiline = 1;
4627     }
4628
4629     if (!limit)
4630         limit = maxiters + 2;
4631     if (pm->op_pmflags & PMf_WHITE) {
4632         while (--limit) {
4633             m = s;
4634             /* this one uses 'm' and is a negative test */
4635             if (do_utf8) {
4636                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4637                     const int t = UTF8SKIP(m);
4638                     /* is_utf8_space returns FALSE for malform utf8 */
4639                     if (strend - m < t)
4640                         m = strend;
4641                     else
4642                         m += t;
4643                 }
4644             } else if (pm->op_pmflags & PMf_LOCALE) {
4645                 while (m < strend && !isSPACE_LC(*m))
4646                     ++m;
4647             } else {
4648                 while (m < strend && !isSPACE(*m))
4649                     ++m;
4650             }
4651             if (m >= strend)
4652                 break;
4653
4654             dstr = newSVpvn(s, m-s);
4655             if (make_mortal)
4656                 sv_2mortal(dstr);
4657             if (do_utf8)
4658                 (void)SvUTF8_on(dstr);
4659             XPUSHs(dstr);
4660
4661             /* skip the whitespace found last */
4662             if (do_utf8)
4663                 s = m + UTF8SKIP(m);
4664             else
4665                 s = m + 1;
4666
4667             /* this one uses 's' and is a positive test */
4668             if (do_utf8) {
4669                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4670                     s +=  UTF8SKIP(s);
4671             } else if (pm->op_pmflags & PMf_LOCALE) {
4672                 while (s < strend && isSPACE_LC(*s))
4673                     ++s;
4674             } else {
4675                 while (s < strend && isSPACE(*s))
4676                     ++s;
4677             }
4678         }
4679     }
4680     else if (rx->extflags & RXf_START_ONLY) {
4681         while (--limit) {
4682             for (m = s; m < strend && *m != '\n'; m++)
4683                 ;
4684             m++;
4685             if (m >= strend)
4686                 break;
4687             dstr = newSVpvn(s, m-s);
4688             if (make_mortal)
4689                 sv_2mortal(dstr);
4690             if (do_utf8)
4691                 (void)SvUTF8_on(dstr);
4692             XPUSHs(dstr);
4693             s = m;
4694         }
4695     }
4696     else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
4697              (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
4698              && (rx->extflags & RXf_CHECK_ALL)
4699              && !(rx->extflags & RXf_ANCH)) {
4700         const int tail = (rx->extflags & RXf_INTUIT_TAIL);
4701         SV * const csv = CALLREG_INTUIT_STRING(rx);
4702
4703         len = rx->minlenret;
4704         if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
4705             const char c = *SvPV_nolen_const(csv);
4706             while (--limit) {
4707                 for (m = s; m < strend && *m != c; m++)
4708                     ;
4709                 if (m >= strend)
4710                     break;
4711                 dstr = newSVpvn(s, m-s);
4712                 if (make_mortal)
4713                     sv_2mortal(dstr);
4714                 if (do_utf8)
4715                     (void)SvUTF8_on(dstr);
4716                 XPUSHs(dstr);
4717                 /* The rx->minlen is in characters but we want to step
4718                  * s ahead by bytes. */
4719                 if (do_utf8)
4720                     s = (char*)utf8_hop((U8*)m, len);
4721                 else
4722                     s = m + len; /* Fake \n at the end */
4723             }
4724         }
4725         else {
4726             while (s < strend && --limit &&
4727               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4728                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4729             {
4730                 dstr = newSVpvn(s, m-s);
4731                 if (make_mortal)
4732                     sv_2mortal(dstr);
4733                 if (do_utf8)
4734                     (void)SvUTF8_on(dstr);
4735                 XPUSHs(dstr);
4736                 /* The rx->minlen is in characters but we want to step
4737                  * s ahead by bytes. */
4738                 if (do_utf8)
4739                     s = (char*)utf8_hop((U8*)m, len);
4740                 else
4741                     s = m + len; /* Fake \n at the end */
4742             }
4743         }
4744     }
4745     else {
4746         maxiters += slen * rx->nparens;
4747         while (s < strend && --limit)
4748         {
4749             I32 rex_return;
4750             PUTBACK;
4751             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4752                             sv, NULL, 0);
4753             SPAGAIN;
4754             if (rex_return == 0)
4755                 break;
4756             TAINT_IF(RX_MATCH_TAINTED(rx));
4757             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4758                 m = s;
4759                 s = orig;
4760                 orig = rx->subbeg;
4761                 s = orig + (m - s);
4762                 strend = s + (strend - m);
4763             }
4764             m = rx->startp[0] + orig;
4765             dstr = newSVpvn(s, m-s);
4766             if (make_mortal)
4767                 sv_2mortal(dstr);
4768             if (do_utf8)
4769                 (void)SvUTF8_on(dstr);
4770             XPUSHs(dstr);
4771             if (rx->nparens) {
4772                 I32 i;
4773                 for (i = 1; i <= (I32)rx->nparens; i++) {
4774                     s = rx->startp[i] + orig;
4775                     m = rx->endp[i] + orig;
4776
4777                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4778                        parens that didn't match -- they should be set to
4779                        undef, not the empty string */
4780                     if (m >= orig && s >= orig) {
4781                         dstr = newSVpvn(s, m-s);
4782                     }
4783                     else
4784                         dstr = &PL_sv_undef;  /* undef, not "" */
4785                     if (make_mortal)
4786                         sv_2mortal(dstr);
4787                     if (do_utf8)
4788                         (void)SvUTF8_on(dstr);
4789                     XPUSHs(dstr);
4790                 }
4791             }
4792             s = rx->endp[0] + orig;
4793         }
4794     }
4795
4796     iters = (SP - PL_stack_base) - base;
4797     if (iters > maxiters)
4798         DIE(aTHX_ "Split loop");
4799
4800     /* keep field after final delim? */
4801     if (s < strend || (iters && origlimit)) {
4802         const STRLEN l = strend - s;
4803         dstr = newSVpvn(s, l);
4804         if (make_mortal)
4805             sv_2mortal(dstr);
4806         if (do_utf8)
4807             (void)SvUTF8_on(dstr);
4808         XPUSHs(dstr);
4809         iters++;
4810     }
4811     else if (!origlimit) {
4812         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4813             if (TOPs && !make_mortal)
4814                 sv_2mortal(TOPs);
4815             iters--;
4816             *SP-- = &PL_sv_undef;
4817         }
4818     }
4819
4820     PUTBACK;
4821     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4822     SPAGAIN;
4823     if (realarray) {
4824         if (!mg) {
4825             if (SvSMAGICAL(ary)) {
4826                 PUTBACK;
4827                 mg_set((SV*)ary);
4828                 SPAGAIN;
4829             }
4830             if (gimme == G_ARRAY) {
4831                 EXTEND(SP, iters);
4832                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4833                 SP += iters;
4834                 RETURN;
4835             }
4836         }
4837         else {
4838             PUTBACK;
4839             ENTER;
4840             call_method("PUSH",G_SCALAR|G_DISCARD);
4841             LEAVE;
4842             SPAGAIN;
4843             if (gimme == G_ARRAY) {
4844                 I32 i;
4845                 /* EXTEND should not be needed - we just popped them */
4846                 EXTEND(SP, iters);
4847                 for (i=0; i < iters; i++) {
4848                     SV **svp = av_fetch(ary, i, FALSE);
4849                     PUSHs((svp) ? *svp : &PL_sv_undef);
4850                 }
4851                 RETURN;
4852             }
4853         }
4854     }
4855     else {
4856         if (gimme == G_ARRAY)
4857             RETURN;
4858     }
4859
4860     GETTARGET;
4861     PUSHi(iters);
4862     RETURN;
4863 }
4864
4865 PP(pp_lock)
4866 {
4867     dVAR;
4868     dSP;
4869     dTOPss;
4870     SV *retsv = sv;
4871     SvLOCK(sv);
4872     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4873         || SvTYPE(retsv) == SVt_PVCV) {
4874         retsv = refto(retsv);
4875     }
4876     SETs(retsv);
4877     RETURN;
4878 }
4879
4880
4881 PP(unimplemented_op)
4882 {
4883     dVAR;
4884     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4885         PL_op->op_type);
4886 }
4887
4888 /*
4889  * Local variables:
4890  * c-indentation-style: bsd
4891  * c-basic-offset: 4
4892  * indent-tabs-mode: t
4893  * End:
4894  *
4895  * ex: set ts=8 sts=4 sw=4 noet:
4896  */