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 int num_args = PL_op->op_private & 7;
3018     const I32 lvalue = num_args <= 3 && ( PL_op->op_flags & OPf_MOD || LVRET );
3019     const char *tmps;
3020     const I32 arybase = CopARYBASE_get(PL_curcop);
3021     SV *repl_sv = NULL;
3022     const char *repl = NULL;
3023     STRLEN repl_len;
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         if (! lvalue)
3119             sv_setpvn(TARG, tmps, rem);
3120 #ifdef USE_LOCALE_COLLATE
3121         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3122 #endif
3123         if (utf8_curlen)
3124             SvUTF8_on(TARG);
3125         if (repl) {
3126             SV* repl_sv_copy = NULL;
3127
3128             if (repl_need_utf8_upgrade) {
3129                 repl_sv_copy = newSVsv(repl_sv);
3130                 sv_utf8_upgrade(repl_sv_copy);
3131                 repl = SvPV_const(repl_sv_copy, repl_len);
3132                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3133             }
3134             sv_insert(sv, pos, rem, repl, repl_len);
3135             if (repl_is_utf8)
3136                 SvUTF8_on(sv);
3137             if (repl_sv_copy)
3138                 SvREFCNT_dec(repl_sv_copy);
3139         }
3140         else if (lvalue) {              /* it's an lvalue! */
3141             if (!SvGMAGICAL(sv)) {
3142                 if (SvROK(sv)) {
3143                     SvPV_force_nolen(sv);
3144                     if (ckWARN(WARN_SUBSTR))
3145                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3146                                 "Attempt to use reference as lvalue in substr");
3147                 }
3148                 if (isGV_with_GP(sv))
3149                     SvPV_force_nolen(sv);
3150                 else if (SvOK(sv))      /* is it defined ? */
3151                     (void)SvPOK_only_UTF8(sv);
3152                 else
3153                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3154             }
3155
3156             if (SvTYPE(TARG) < SVt_PVLV) {
3157                 sv_upgrade(TARG, SVt_PVLV);
3158                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3159             }
3160
3161             LvTYPE(TARG) = 'x';
3162             if (LvTARG(TARG) != sv) {
3163                 if (LvTARG(TARG))
3164                     SvREFCNT_dec(LvTARG(TARG));
3165                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3166             }
3167             LvTARGOFF(TARG) = upos;
3168             LvTARGLEN(TARG) = urem;
3169         }
3170     }
3171     SPAGAIN;
3172     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3173     RETURN;
3174 }
3175
3176 PP(pp_vec)
3177 {
3178     dVAR; dSP; dTARGET;
3179     register const IV size   = POPi;
3180     register const IV offset = POPi;
3181     register SV * const src = POPs;
3182     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3183
3184     SvTAINTED_off(TARG);                /* decontaminate */
3185     if (lvalue) {                       /* it's an lvalue! */
3186         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3187             TARG = sv_newmortal();
3188         if (SvTYPE(TARG) < SVt_PVLV) {
3189             sv_upgrade(TARG, SVt_PVLV);
3190             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3191         }
3192         LvTYPE(TARG) = 'v';
3193         if (LvTARG(TARG) != src) {
3194             if (LvTARG(TARG))
3195                 SvREFCNT_dec(LvTARG(TARG));
3196             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3197         }
3198         LvTARGOFF(TARG) = offset;
3199         LvTARGLEN(TARG) = size;
3200     }
3201
3202     sv_setuv(TARG, do_vecget(src, offset, size));
3203     PUSHs(TARG);
3204     RETURN;
3205 }
3206
3207 PP(pp_index)
3208 {
3209     dVAR; dSP; dTARGET;
3210     SV *big;
3211     SV *little;
3212     SV *temp = NULL;
3213     STRLEN biglen;
3214     STRLEN llen = 0;
3215     I32 offset;
3216     I32 retval;
3217     const char *big_p;
3218     const char *little_p;
3219     const I32 arybase = CopARYBASE_get(PL_curcop);
3220     bool big_utf8;
3221     bool little_utf8;
3222     const bool is_index = PL_op->op_type == OP_INDEX;
3223
3224     if (MAXARG >= 3) {
3225         /* arybase is in characters, like offset, so combine prior to the
3226            UTF-8 to bytes calculation.  */
3227         offset = POPi - arybase;
3228     }
3229     little = POPs;
3230     big = POPs;
3231     big_p = SvPV_const(big, biglen);
3232     little_p = SvPV_const(little, llen);
3233
3234     big_utf8 = DO_UTF8(big);
3235     little_utf8 = DO_UTF8(little);
3236     if (big_utf8 ^ little_utf8) {
3237         /* One needs to be upgraded.  */
3238         if (little_utf8 && !PL_encoding) {
3239             /* Well, maybe instead we might be able to downgrade the small
3240                string?  */
3241             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3242                                                      &little_utf8);
3243             if (little_utf8) {
3244                 /* If the large string is ISO-8859-1, and it's not possible to
3245                    convert the small string to ISO-8859-1, then there is no
3246                    way that it could be found anywhere by index.  */
3247                 retval = -1;
3248                 goto fail;
3249             }
3250
3251             /* At this point, pv is a malloc()ed string. So donate it to temp
3252                to ensure it will get free()d  */
3253             little = temp = newSV(0);
3254             sv_usepvn(temp, pv, llen);
3255             little_p = SvPVX(little);
3256         } else {
3257             temp = little_utf8
3258                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3259
3260             if (PL_encoding) {
3261                 sv_recode_to_utf8(temp, PL_encoding);
3262             } else {
3263                 sv_utf8_upgrade(temp);
3264             }
3265             if (little_utf8) {
3266                 big = temp;
3267                 big_utf8 = TRUE;
3268                 big_p = SvPV_const(big, biglen);
3269             } else {
3270                 little = temp;
3271                 little_p = SvPV_const(little, llen);
3272             }
3273         }
3274     }
3275     if (SvGAMAGIC(big)) {
3276         /* Life just becomes a lot easier if I use a temporary here.
3277            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3278            will trigger magic and overloading again, as will fbm_instr()
3279         */
3280         big = sv_2mortal(newSVpvn(big_p, biglen));
3281         if (big_utf8)
3282             SvUTF8_on(big);
3283         big_p = SvPVX(big);
3284     }
3285     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3286         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3287            warn on undef, and we've already triggered a warning with the
3288            SvPV_const some lines above. We can't remove that, as we need to
3289            call some SvPV to trigger overloading early and find out if the
3290            string is UTF-8.
3291            This is all getting to messy. The API isn't quite clean enough,
3292            because data access has side effects.
3293         */
3294         little = sv_2mortal(newSVpvn(little_p, llen));
3295         if (little_utf8)
3296             SvUTF8_on(little);
3297         little_p = SvPVX(little);
3298     }
3299
3300     if (MAXARG < 3)
3301         offset = is_index ? 0 : biglen;
3302     else {
3303         if (big_utf8 && offset > 0)
3304             sv_pos_u2b(big, &offset, 0);
3305         if (!is_index)
3306             offset += llen;
3307     }
3308     if (offset < 0)
3309         offset = 0;
3310     else if (offset > (I32)biglen)
3311         offset = biglen;
3312     if (!(little_p = is_index
3313           ? fbm_instr((unsigned char*)big_p + offset,
3314                       (unsigned char*)big_p + biglen, little, 0)
3315           : rninstr(big_p,  big_p  + offset,
3316                     little_p, little_p + llen)))
3317         retval = -1;
3318     else {
3319         retval = little_p - big_p;
3320         if (retval > 0 && big_utf8)
3321             sv_pos_b2u(big, &retval);
3322     }
3323     if (temp)
3324         SvREFCNT_dec(temp);
3325  fail:
3326     PUSHi(retval + arybase);
3327     RETURN;
3328 }
3329
3330 PP(pp_sprintf)
3331 {
3332     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3333     if (SvTAINTED(MARK[1]))
3334         TAINT_PROPER("sprintf");
3335     do_sprintf(TARG, SP-MARK, MARK+1);
3336     TAINT_IF(SvTAINTED(TARG));
3337     SP = ORIGMARK;
3338     PUSHTARG;
3339     RETURN;
3340 }
3341
3342 PP(pp_ord)
3343 {
3344     dVAR; dSP; dTARGET;
3345
3346     SV *argsv = POPs;
3347     STRLEN len;
3348     const U8 *s = (U8*)SvPV_const(argsv, len);
3349
3350     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3351         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3352         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3353         argsv = tmpsv;
3354     }
3355
3356     XPUSHu(DO_UTF8(argsv) ?
3357            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3358            (*s & 0xff));
3359
3360     RETURN;
3361 }
3362
3363 PP(pp_chr)
3364 {
3365     dVAR; dSP; dTARGET;
3366     char *tmps;
3367     UV value;
3368
3369     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3370          ||
3371          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3372         if (IN_BYTES) {
3373             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3374         } else {
3375             (void) POPs; /* Ignore the argument value. */
3376             value = UNICODE_REPLACEMENT;
3377         }
3378     } else {
3379         value = POPu;
3380     }
3381
3382     SvUPGRADE(TARG,SVt_PV);
3383
3384     if (value > 255 && !IN_BYTES) {
3385         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3386         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3387         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3388         *tmps = '\0';
3389         (void)SvPOK_only(TARG);
3390         SvUTF8_on(TARG);
3391         XPUSHs(TARG);
3392         RETURN;
3393     }
3394
3395     SvGROW(TARG,2);
3396     SvCUR_set(TARG, 1);
3397     tmps = SvPVX(TARG);
3398     *tmps++ = (char)value;
3399     *tmps = '\0';
3400     (void)SvPOK_only(TARG);
3401
3402     if (PL_encoding && !IN_BYTES) {
3403         sv_recode_to_utf8(TARG, PL_encoding);
3404         tmps = SvPVX(TARG);
3405         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3406             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3407             SvGROW(TARG, 2);
3408             tmps = SvPVX(TARG);
3409             SvCUR_set(TARG, 1);
3410             *tmps++ = (char)value;
3411             *tmps = '\0';
3412             SvUTF8_off(TARG);
3413         }
3414     }
3415
3416     XPUSHs(TARG);
3417     RETURN;
3418 }
3419
3420 PP(pp_crypt)
3421 {
3422 #ifdef HAS_CRYPT
3423     dVAR; dSP; dTARGET;
3424     dPOPTOPssrl;
3425     STRLEN len;
3426     const char *tmps = SvPV_const(left, len);
3427
3428     if (DO_UTF8(left)) {
3429          /* If Unicode, try to downgrade.
3430           * If not possible, croak.
3431           * Yes, we made this up.  */
3432          SV* const tsv = sv_2mortal(newSVsv(left));
3433
3434          SvUTF8_on(tsv);
3435          sv_utf8_downgrade(tsv, FALSE);
3436          tmps = SvPV_const(tsv, len);
3437     }
3438 #   ifdef USE_ITHREADS
3439 #     ifdef HAS_CRYPT_R
3440     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3441       /* This should be threadsafe because in ithreads there is only
3442        * one thread per interpreter.  If this would not be true,
3443        * we would need a mutex to protect this malloc. */
3444         PL_reentrant_buffer->_crypt_struct_buffer =
3445           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3446 #if defined(__GLIBC__) || defined(__EMX__)
3447         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3448             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3449             /* work around glibc-2.2.5 bug */
3450             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3451         }
3452 #endif
3453     }
3454 #     endif /* HAS_CRYPT_R */
3455 #   endif /* USE_ITHREADS */
3456 #   ifdef FCRYPT
3457     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3458 #   else
3459     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3460 #   endif
3461     SETs(TARG);
3462     RETURN;
3463 #else
3464     DIE(aTHX_
3465       "The crypt() function is unimplemented due to excessive paranoia.");
3466 #endif
3467 }
3468
3469 PP(pp_ucfirst)
3470 {
3471     dVAR;
3472     dSP;
3473     SV *source = TOPs;
3474     STRLEN slen;
3475     STRLEN need;
3476     SV *dest;
3477     bool inplace = TRUE;
3478     bool doing_utf8;
3479     const int op_type = PL_op->op_type;
3480     const U8 *s;
3481     U8 *d;
3482     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3483     STRLEN ulen;
3484     STRLEN tculen;
3485
3486     SvGETMAGIC(source);
3487     if (SvOK(source)) {
3488         s = (const U8*)SvPV_nomg_const(source, slen);
3489     } else {
3490         s = (const U8*)"";
3491         slen = 0;
3492     }
3493
3494     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3495         doing_utf8 = TRUE;
3496         utf8_to_uvchr(s, &ulen);
3497         if (op_type == OP_UCFIRST) {
3498             toTITLE_utf8(s, tmpbuf, &tculen);
3499         } else {
3500             toLOWER_utf8(s, tmpbuf, &tculen);
3501         }
3502         /* If the two differ, we definately cannot do inplace.  */
3503         inplace = (ulen == tculen);
3504         need = slen + 1 - ulen + tculen;
3505     } else {
3506         doing_utf8 = FALSE;
3507         need = slen + 1;
3508     }
3509
3510     if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3511         /* We can convert in place.  */
3512
3513         dest = source;
3514         s = d = (U8*)SvPV_force_nomg(source, slen);
3515     } else {
3516         dTARGET;
3517
3518         dest = TARG;
3519
3520         SvUPGRADE(dest, SVt_PV);
3521         d = (U8*)SvGROW(dest, need);
3522         (void)SvPOK_only(dest);
3523
3524         SETs(dest);
3525
3526         inplace = FALSE;
3527     }
3528
3529     if (doing_utf8) {
3530         if(!inplace) {
3531             /* slen is the byte length of the whole SV.
3532              * ulen is the byte length of the original Unicode character
3533              * stored as UTF-8 at s.
3534              * tculen is the byte length of the freshly titlecased (or
3535              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3536              * We first set the result to be the titlecased (/lowercased)
3537              * character, and then append the rest of the SV data. */
3538             sv_setpvn(dest, (char*)tmpbuf, tculen);
3539             if (slen > ulen)
3540                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3541             SvUTF8_on(dest);
3542         }
3543         else {
3544             Copy(tmpbuf, d, tculen, U8);
3545             SvCUR_set(dest, need - 1);
3546         }
3547     }
3548     else {
3549         if (*s) {
3550             if (IN_LOCALE_RUNTIME) {
3551                 TAINT;
3552                 SvTAINTED_on(dest);
3553                 *d = (op_type == OP_UCFIRST)
3554                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3555             }
3556             else
3557                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3558         } else {
3559             /* See bug #39028  */
3560             *d = *s;
3561         }
3562
3563         if (SvUTF8(source))
3564             SvUTF8_on(dest);
3565
3566         if (!inplace) {
3567             /* This will copy the trailing NUL  */
3568             Copy(s + 1, d + 1, slen, U8);
3569             SvCUR_set(dest, need - 1);
3570         }
3571     }
3572     SvSETMAGIC(dest);
3573     RETURN;
3574 }
3575
3576 /* There's so much setup/teardown code common between uc and lc, I wonder if
3577    it would be worth merging the two, and just having a switch outside each
3578    of the three tight loops.  */
3579 PP(pp_uc)
3580 {
3581     dVAR;
3582     dSP;
3583     SV *source = TOPs;
3584     STRLEN len;
3585     STRLEN min;
3586     SV *dest;
3587     const U8 *s;
3588     U8 *d;
3589
3590     SvGETMAGIC(source);
3591
3592     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3593         && !DO_UTF8(source)) {
3594         /* We can convert in place.  */
3595
3596         dest = source;
3597         s = d = (U8*)SvPV_force_nomg(source, len);
3598         min = len + 1;
3599     } else {
3600         dTARGET;
3601
3602         dest = TARG;
3603
3604         /* The old implementation would copy source into TARG at this point.
3605            This had the side effect that if source was undef, TARG was now
3606            an undefined SV with PADTMP set, and they don't warn inside
3607            sv_2pv_flags(). However, we're now getting the PV direct from
3608            source, which doesn't have PADTMP set, so it would warn. Hence the
3609            little games.  */
3610
3611         if (SvOK(source)) {
3612             s = (const U8*)SvPV_nomg_const(source, len);
3613         } else {
3614             s = (const U8*)"";
3615             len = 0;
3616         }
3617         min = len + 1;
3618
3619         SvUPGRADE(dest, SVt_PV);
3620         d = (U8*)SvGROW(dest, min);
3621         (void)SvPOK_only(dest);
3622
3623         SETs(dest);
3624     }
3625
3626     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3627        to check DO_UTF8 again here.  */
3628
3629     if (DO_UTF8(source)) {
3630         const U8 *const send = s + len;
3631         U8 tmpbuf[UTF8_MAXBYTES+1];
3632
3633         while (s < send) {
3634             const STRLEN u = UTF8SKIP(s);
3635             STRLEN ulen;
3636
3637             toUPPER_utf8(s, tmpbuf, &ulen);
3638             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3639                 /* If the eventually required minimum size outgrows
3640                  * the available space, we need to grow. */
3641                 const UV o = d - (U8*)SvPVX_const(dest);
3642
3643                 /* If someone uppercases one million U+03B0s we SvGROW() one
3644                  * million times.  Or we could try guessing how much to
3645                  allocate without allocating too much.  Such is life. */
3646                 SvGROW(dest, min);
3647                 d = (U8*)SvPVX(dest) + o;
3648             }
3649             Copy(tmpbuf, d, ulen, U8);
3650             d += ulen;
3651             s += u;
3652         }
3653         SvUTF8_on(dest);
3654         *d = '\0';
3655         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3656     } else {
3657         if (len) {
3658             const U8 *const send = s + len;
3659             if (IN_LOCALE_RUNTIME) {
3660                 TAINT;
3661                 SvTAINTED_on(dest);
3662                 for (; s < send; d++, s++)
3663                     *d = toUPPER_LC(*s);
3664             }
3665             else {
3666                 for (; s < send; d++, s++)
3667                     *d = toUPPER(*s);
3668             }
3669         }
3670         if (source != dest) {
3671             *d = '\0';
3672             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3673         }
3674     }
3675     SvSETMAGIC(dest);
3676     RETURN;
3677 }
3678
3679 PP(pp_lc)
3680 {
3681     dVAR;
3682     dSP;
3683     SV *source = TOPs;
3684     STRLEN len;
3685     STRLEN min;
3686     SV *dest;
3687     const U8 *s;
3688     U8 *d;
3689
3690     SvGETMAGIC(source);
3691
3692     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3693         && !DO_UTF8(source)) {
3694         /* We can convert in place.  */
3695
3696         dest = source;
3697         s = d = (U8*)SvPV_force_nomg(source, len);
3698         min = len + 1;
3699     } else {
3700         dTARGET;
3701
3702         dest = TARG;
3703
3704         /* The old implementation would copy source into TARG at this point.
3705            This had the side effect that if source was undef, TARG was now
3706            an undefined SV with PADTMP set, and they don't warn inside
3707            sv_2pv_flags(). However, we're now getting the PV direct from
3708            source, which doesn't have PADTMP set, so it would warn. Hence the
3709            little games.  */
3710
3711         if (SvOK(source)) {
3712             s = (const U8*)SvPV_nomg_const(source, len);
3713         } else {
3714             s = (const U8*)"";
3715             len = 0;
3716         }
3717         min = len + 1;
3718
3719         SvUPGRADE(dest, SVt_PV);
3720         d = (U8*)SvGROW(dest, min);
3721         (void)SvPOK_only(dest);
3722
3723         SETs(dest);
3724     }
3725
3726     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3727        to check DO_UTF8 again here.  */
3728
3729     if (DO_UTF8(source)) {
3730         const U8 *const send = s + len;
3731         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3732
3733         while (s < send) {
3734             const STRLEN u = UTF8SKIP(s);
3735             STRLEN ulen;
3736             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3737
3738 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3739             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3740                 NOOP;
3741                 /*
3742                  * Now if the sigma is NOT followed by
3743                  * /$ignorable_sequence$cased_letter/;
3744                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3745                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3746                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3747                  * then it should be mapped to 0x03C2,
3748                  * (GREEK SMALL LETTER FINAL SIGMA),
3749                  * instead of staying 0x03A3.
3750                  * "should be": in other words, this is not implemented yet.
3751                  * See lib/unicore/SpecialCasing.txt.
3752                  */
3753             }
3754             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3755                 /* If the eventually required minimum size outgrows
3756                  * the available space, we need to grow. */
3757                 const UV o = d - (U8*)SvPVX_const(dest);
3758
3759                 /* If someone lowercases one million U+0130s we SvGROW() one
3760                  * million times.  Or we could try guessing how much to
3761                  allocate without allocating too much.  Such is life. */
3762                 SvGROW(dest, min);
3763                 d = (U8*)SvPVX(dest) + o;
3764             }
3765             Copy(tmpbuf, d, ulen, U8);
3766             d += ulen;
3767             s += u;
3768         }
3769         SvUTF8_on(dest);
3770         *d = '\0';
3771         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3772     } else {
3773         if (len) {
3774             const U8 *const send = s + len;
3775             if (IN_LOCALE_RUNTIME) {
3776                 TAINT;
3777                 SvTAINTED_on(dest);
3778                 for (; s < send; d++, s++)
3779                     *d = toLOWER_LC(*s);
3780             }
3781             else {
3782                 for (; s < send; d++, s++)
3783                     *d = toLOWER(*s);
3784             }
3785         }
3786         if (source != dest) {
3787             *d = '\0';
3788             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3789         }
3790     }
3791     SvSETMAGIC(dest);
3792     RETURN;
3793 }
3794
3795 PP(pp_quotemeta)
3796 {
3797     dVAR; dSP; dTARGET;
3798     SV * const sv = TOPs;
3799     STRLEN len;
3800     register const char *s = SvPV_const(sv,len);
3801
3802     SvUTF8_off(TARG);                           /* decontaminate */
3803     if (len) {
3804         register char *d;
3805         SvUPGRADE(TARG, SVt_PV);
3806         SvGROW(TARG, (len * 2) + 1);
3807         d = SvPVX(TARG);
3808         if (DO_UTF8(sv)) {
3809             while (len) {
3810                 if (UTF8_IS_CONTINUED(*s)) {
3811                     STRLEN ulen = UTF8SKIP(s);
3812                     if (ulen > len)
3813                         ulen = len;
3814                     len -= ulen;
3815                     while (ulen--)
3816                         *d++ = *s++;
3817                 }
3818                 else {
3819                     if (!isALNUM(*s))
3820                         *d++ = '\\';
3821                     *d++ = *s++;
3822                     len--;
3823                 }
3824             }
3825             SvUTF8_on(TARG);
3826         }
3827         else {
3828             while (len--) {
3829                 if (!isALNUM(*s))
3830                     *d++ = '\\';
3831                 *d++ = *s++;
3832             }
3833         }
3834         *d = '\0';
3835         SvCUR_set(TARG, d - SvPVX_const(TARG));
3836         (void)SvPOK_only_UTF8(TARG);
3837     }
3838     else
3839         sv_setpvn(TARG, s, len);
3840     SETs(TARG);
3841     if (SvSMAGICAL(TARG))
3842         mg_set(TARG);
3843     RETURN;
3844 }
3845
3846 /* Arrays. */
3847
3848 PP(pp_aslice)
3849 {
3850     dVAR; dSP; dMARK; dORIGMARK;
3851     register AV* const av = (AV*)POPs;
3852     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3853
3854     if (SvTYPE(av) == SVt_PVAV) {
3855         const I32 arybase = CopARYBASE_get(PL_curcop);
3856         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3857             register SV **svp;
3858             I32 max = -1;
3859             for (svp = MARK + 1; svp <= SP; svp++) {
3860                 const I32 elem = SvIVx(*svp);
3861                 if (elem > max)
3862                     max = elem;
3863             }
3864             if (max > AvMAX(av))
3865                 av_extend(av, max);
3866         }
3867         while (++MARK <= SP) {
3868             register SV **svp;
3869             I32 elem = SvIVx(*MARK);
3870
3871             if (elem > 0)
3872                 elem -= arybase;
3873             svp = av_fetch(av, elem, lval);
3874             if (lval) {
3875                 if (!svp || *svp == &PL_sv_undef)
3876                     DIE(aTHX_ PL_no_aelem, elem);
3877                 if (PL_op->op_private & OPpLVAL_INTRO)
3878                     save_aelem(av, elem, svp);
3879             }
3880             *MARK = svp ? *svp : &PL_sv_undef;
3881         }
3882     }
3883     if (GIMME != G_ARRAY) {
3884         MARK = ORIGMARK;
3885         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3886         SP = MARK;
3887     }
3888     RETURN;
3889 }
3890
3891 /* Associative arrays. */
3892
3893 PP(pp_each)
3894 {
3895     dVAR;
3896     dSP;
3897     HV * hash = (HV*)POPs;
3898     HE *entry;
3899     const I32 gimme = GIMME_V;
3900
3901     PUTBACK;
3902     /* might clobber stack_sp */
3903     entry = hv_iternext(hash);
3904     SPAGAIN;
3905
3906     EXTEND(SP, 2);
3907     if (entry) {
3908         SV* const sv = hv_iterkeysv(entry);
3909         PUSHs(sv);      /* won't clobber stack_sp */
3910         if (gimme == G_ARRAY) {
3911             SV *val;
3912             PUTBACK;
3913             /* might clobber stack_sp */
3914             val = hv_iterval(hash, entry);
3915             SPAGAIN;
3916             PUSHs(val);
3917         }
3918     }
3919     else if (gimme == G_SCALAR)
3920         RETPUSHUNDEF;
3921
3922     RETURN;
3923 }
3924
3925 PP(pp_delete)
3926 {
3927     dVAR;
3928     dSP;
3929     const I32 gimme = GIMME_V;
3930     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3931
3932     if (PL_op->op_private & OPpSLICE) {
3933         dMARK; dORIGMARK;
3934         HV * const hv = (HV*)POPs;
3935         const U32 hvtype = SvTYPE(hv);
3936         if (hvtype == SVt_PVHV) {                       /* hash element */
3937             while (++MARK <= SP) {
3938                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3939                 *MARK = sv ? sv : &PL_sv_undef;
3940             }
3941         }
3942         else if (hvtype == SVt_PVAV) {                  /* array element */
3943             if (PL_op->op_flags & OPf_SPECIAL) {
3944                 while (++MARK <= SP) {
3945                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3946                     *MARK = sv ? sv : &PL_sv_undef;
3947                 }
3948             }
3949         }
3950         else
3951             DIE(aTHX_ "Not a HASH reference");
3952         if (discard)
3953             SP = ORIGMARK;
3954         else if (gimme == G_SCALAR) {
3955             MARK = ORIGMARK;
3956             if (SP > MARK)
3957                 *++MARK = *SP;
3958             else
3959                 *++MARK = &PL_sv_undef;
3960             SP = MARK;
3961         }
3962     }
3963     else {
3964         SV *keysv = POPs;
3965         HV * const hv = (HV*)POPs;
3966         SV *sv;
3967         if (SvTYPE(hv) == SVt_PVHV)
3968             sv = hv_delete_ent(hv, keysv, discard, 0);
3969         else if (SvTYPE(hv) == SVt_PVAV) {
3970             if (PL_op->op_flags & OPf_SPECIAL)
3971                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3972             else
3973                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3974         }
3975         else
3976             DIE(aTHX_ "Not a HASH reference");
3977         if (!sv)
3978             sv = &PL_sv_undef;
3979         if (!discard)
3980             PUSHs(sv);
3981     }
3982     RETURN;
3983 }
3984
3985 PP(pp_exists)
3986 {
3987     dVAR;
3988     dSP;
3989     SV *tmpsv;
3990     HV *hv;
3991
3992     if (PL_op->op_private & OPpEXISTS_SUB) {
3993         GV *gv;
3994         SV * const sv = POPs;
3995         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3996         if (cv)
3997             RETPUSHYES;
3998         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3999             RETPUSHYES;
4000         RETPUSHNO;
4001     }
4002     tmpsv = POPs;
4003     hv = (HV*)POPs;
4004     if (SvTYPE(hv) == SVt_PVHV) {
4005         if (hv_exists_ent(hv, tmpsv, 0))
4006             RETPUSHYES;
4007     }
4008     else if (SvTYPE(hv) == SVt_PVAV) {
4009         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4010             if (av_exists((AV*)hv, SvIV(tmpsv)))
4011                 RETPUSHYES;
4012         }
4013     }
4014     else {
4015         DIE(aTHX_ "Not a HASH reference");
4016     }
4017     RETPUSHNO;
4018 }
4019
4020 PP(pp_hslice)
4021 {
4022     dVAR; dSP; dMARK; dORIGMARK;
4023     register HV * const hv = (HV*)POPs;
4024     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4025     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4026     bool other_magic = FALSE;
4027
4028     if (localizing) {
4029         MAGIC *mg;
4030         HV *stash;
4031
4032         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4033             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4034              /* Try to preserve the existenceness of a tied hash
4035               * element by using EXISTS and DELETE if possible.
4036               * Fallback to FETCH and STORE otherwise */
4037              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4038              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4039              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4040     }
4041
4042     while (++MARK <= SP) {
4043         SV * const keysv = *MARK;
4044         SV **svp;
4045         HE *he;
4046         bool preeminent = FALSE;
4047
4048         if (localizing) {
4049             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4050                 hv_exists_ent(hv, keysv, 0);
4051         }
4052
4053         he = hv_fetch_ent(hv, keysv, lval, 0);
4054         svp = he ? &HeVAL(he) : 0;
4055
4056         if (lval) {
4057             if (!svp || *svp == &PL_sv_undef) {
4058                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4059             }
4060             if (localizing) {
4061                 if (HvNAME_get(hv) && isGV(*svp))
4062                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4063                 else {
4064                     if (preeminent)
4065                         save_helem(hv, keysv, svp);
4066                     else {
4067                         STRLEN keylen;
4068                         const char * const key = SvPV_const(keysv, keylen);
4069                         SAVEDELETE(hv, savepvn(key,keylen),
4070                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4071                     }
4072                 }
4073             }
4074         }
4075         *MARK = svp ? *svp : &PL_sv_undef;
4076     }
4077     if (GIMME != G_ARRAY) {
4078         MARK = ORIGMARK;
4079         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4080         SP = MARK;
4081     }
4082     RETURN;
4083 }
4084
4085 /* List operators. */
4086
4087 PP(pp_list)
4088 {
4089     dVAR; dSP; dMARK;
4090     if (GIMME != G_ARRAY) {
4091         if (++MARK <= SP)
4092             *MARK = *SP;                /* unwanted list, return last item */
4093         else
4094             *MARK = &PL_sv_undef;
4095         SP = MARK;
4096     }
4097     RETURN;
4098 }
4099
4100 PP(pp_lslice)
4101 {
4102     dVAR;
4103     dSP;
4104     SV ** const lastrelem = PL_stack_sp;
4105     SV ** const lastlelem = PL_stack_base + POPMARK;
4106     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4107     register SV ** const firstrelem = lastlelem + 1;
4108     const I32 arybase = CopARYBASE_get(PL_curcop);
4109     I32 is_something_there = FALSE;
4110
4111     register const I32 max = lastrelem - lastlelem;
4112     register SV **lelem;
4113
4114     if (GIMME != G_ARRAY) {
4115         I32 ix = SvIVx(*lastlelem);
4116         if (ix < 0)
4117             ix += max;
4118         else
4119             ix -= arybase;
4120         if (ix < 0 || ix >= max)
4121             *firstlelem = &PL_sv_undef;
4122         else
4123             *firstlelem = firstrelem[ix];
4124         SP = firstlelem;
4125         RETURN;
4126     }
4127
4128     if (max == 0) {
4129         SP = firstlelem - 1;
4130         RETURN;
4131     }
4132
4133     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4134         I32 ix = SvIVx(*lelem);
4135         if (ix < 0)
4136             ix += max;
4137         else
4138             ix -= arybase;
4139         if (ix < 0 || ix >= max)
4140             *lelem = &PL_sv_undef;
4141         else {
4142             is_something_there = TRUE;
4143             if (!(*lelem = firstrelem[ix]))
4144                 *lelem = &PL_sv_undef;
4145         }
4146     }
4147     if (is_something_there)
4148         SP = lastlelem;
4149     else
4150         SP = firstlelem - 1;
4151     RETURN;
4152 }
4153
4154 PP(pp_anonlist)
4155 {
4156     dVAR; dSP; dMARK; dORIGMARK;
4157     const I32 items = SP - MARK;
4158     SV * const av = (SV *) av_make(items, MARK+1);
4159     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4160     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4161                       ? newRV_noinc(av) : av));
4162     RETURN;
4163 }
4164
4165 PP(pp_anonhash)
4166 {
4167     dVAR; dSP; dMARK; dORIGMARK;
4168     HV* const hv = newHV();
4169
4170     while (MARK < SP) {
4171         SV * const key = *++MARK;
4172         SV * const val = newSV(0);
4173         if (MARK < SP)
4174             sv_setsv(val, *++MARK);
4175         else if (ckWARN(WARN_MISC))
4176             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4177         (void)hv_store_ent(hv,key,val,0);
4178     }
4179     SP = ORIGMARK;
4180     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4181                       ? newRV_noinc((SV*) hv) : (SV*)hv));
4182     RETURN;
4183 }
4184
4185 PP(pp_splice)
4186 {
4187     dVAR; dSP; dMARK; dORIGMARK;
4188     register AV *ary = (AV*)*++MARK;
4189     register SV **src;
4190     register SV **dst;
4191     register I32 i;
4192     register I32 offset;
4193     register I32 length;
4194     I32 newlen;
4195     I32 after;
4196     I32 diff;
4197     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4198
4199     if (mg) {
4200         *MARK-- = SvTIED_obj((SV*)ary, mg);
4201         PUSHMARK(MARK);
4202         PUTBACK;
4203         ENTER;
4204         call_method("SPLICE",GIMME_V);
4205         LEAVE;
4206         SPAGAIN;
4207         RETURN;
4208     }
4209
4210     SP++;
4211
4212     if (++MARK < SP) {
4213         offset = i = SvIVx(*MARK);
4214         if (offset < 0)
4215             offset += AvFILLp(ary) + 1;
4216         else
4217             offset -= CopARYBASE_get(PL_curcop);
4218         if (offset < 0)
4219             DIE(aTHX_ PL_no_aelem, i);
4220         if (++MARK < SP) {
4221             length = SvIVx(*MARK++);
4222             if (length < 0) {
4223                 length += AvFILLp(ary) - offset + 1;
4224                 if (length < 0)
4225                     length = 0;
4226             }
4227         }
4228         else
4229             length = AvMAX(ary) + 1;            /* close enough to infinity */
4230     }
4231     else {
4232         offset = 0;
4233         length = AvMAX(ary) + 1;
4234     }
4235     if (offset > AvFILLp(ary) + 1) {
4236         if (ckWARN(WARN_MISC))
4237             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4238         offset = AvFILLp(ary) + 1;
4239     }
4240     after = AvFILLp(ary) + 1 - (offset + length);
4241     if (after < 0) {                            /* not that much array */
4242         length += after;                        /* offset+length now in array */
4243         after = 0;
4244         if (!AvALLOC(ary))
4245             av_extend(ary, 0);
4246     }
4247
4248     /* At this point, MARK .. SP-1 is our new LIST */
4249
4250     newlen = SP - MARK;
4251     diff = newlen - length;
4252     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4253         av_reify(ary);
4254
4255     /* make new elements SVs now: avoid problems if they're from the array */
4256     for (dst = MARK, i = newlen; i; i--) {
4257         SV * const h = *dst;
4258         *dst++ = newSVsv(h);
4259     }
4260
4261     if (diff < 0) {                             /* shrinking the area */
4262         SV **tmparyval = NULL;
4263         if (newlen) {
4264             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4265             Copy(MARK, tmparyval, newlen, SV*);
4266         }
4267
4268         MARK = ORIGMARK + 1;
4269         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4270             MEXTEND(MARK, length);
4271             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4272             if (AvREAL(ary)) {
4273                 EXTEND_MORTAL(length);
4274                 for (i = length, dst = MARK; i; i--) {
4275                     sv_2mortal(*dst);   /* free them eventualy */
4276                     dst++;
4277                 }
4278             }
4279             MARK += length - 1;
4280         }
4281         else {
4282             *MARK = AvARRAY(ary)[offset+length-1];
4283             if (AvREAL(ary)) {
4284                 sv_2mortal(*MARK);
4285                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4286                     SvREFCNT_dec(*dst++);       /* free them now */
4287             }
4288         }
4289         AvFILLp(ary) += diff;
4290
4291         /* pull up or down? */
4292
4293         if (offset < after) {                   /* easier to pull up */
4294             if (offset) {                       /* esp. if nothing to pull */
4295                 src = &AvARRAY(ary)[offset-1];
4296                 dst = src - diff;               /* diff is negative */
4297                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4298                     *dst-- = *src--;
4299             }
4300             dst = AvARRAY(ary);
4301             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4302             AvMAX(ary) += diff;
4303         }
4304         else {
4305             if (after) {                        /* anything to pull down? */
4306                 src = AvARRAY(ary) + offset + length;
4307                 dst = src + diff;               /* diff is negative */
4308                 Move(src, dst, after, SV*);
4309             }
4310             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4311                                                 /* avoid later double free */
4312         }
4313         i = -diff;
4314         while (i)
4315             dst[--i] = &PL_sv_undef;
4316
4317         if (newlen) {
4318             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4319             Safefree(tmparyval);
4320         }
4321     }
4322     else {                                      /* no, expanding (or same) */
4323         SV** tmparyval = NULL;
4324         if (length) {
4325             Newx(tmparyval, length, SV*);       /* so remember deletion */
4326             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4327         }
4328
4329         if (diff > 0) {                         /* expanding */
4330             /* push up or down? */
4331             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4332                 if (offset) {
4333                     src = AvARRAY(ary);
4334                     dst = src - diff;
4335                     Move(src, dst, offset, SV*);
4336                 }
4337                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4338                 AvMAX(ary) += diff;
4339                 AvFILLp(ary) += diff;
4340             }
4341             else {
4342                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4343                     av_extend(ary, AvFILLp(ary) + diff);
4344                 AvFILLp(ary) += diff;
4345
4346                 if (after) {
4347                     dst = AvARRAY(ary) + AvFILLp(ary);
4348                     src = dst - diff;
4349                     for (i = after; i; i--) {
4350                         *dst-- = *src--;
4351                     }
4352                 }
4353             }
4354         }
4355
4356         if (newlen) {
4357             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4358         }
4359
4360         MARK = ORIGMARK + 1;
4361         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4362             if (length) {
4363                 Copy(tmparyval, MARK, length, SV*);
4364                 if (AvREAL(ary)) {
4365                     EXTEND_MORTAL(length);
4366                     for (i = length, dst = MARK; i; i--) {
4367                         sv_2mortal(*dst);       /* free them eventualy */
4368                         dst++;
4369                     }
4370                 }
4371             }
4372             MARK += length - 1;
4373         }
4374         else if (length--) {
4375             *MARK = tmparyval[length];
4376             if (AvREAL(ary)) {
4377                 sv_2mortal(*MARK);
4378                 while (length-- > 0)
4379                     SvREFCNT_dec(tmparyval[length]);
4380             }
4381         }
4382         else
4383             *MARK = &PL_sv_undef;
4384         Safefree(tmparyval);
4385     }
4386     SP = MARK;
4387     RETURN;
4388 }
4389
4390 PP(pp_push)
4391 {
4392     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4393     register AV * const ary = (AV*)*++MARK;
4394     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4395
4396     if (mg) {
4397         *MARK-- = SvTIED_obj((SV*)ary, mg);
4398         PUSHMARK(MARK);
4399         PUTBACK;
4400         ENTER;
4401         call_method("PUSH",G_SCALAR|G_DISCARD);
4402         LEAVE;
4403         SPAGAIN;
4404         SP = ORIGMARK;
4405         PUSHi( AvFILL(ary) + 1 );
4406     }
4407     else {
4408         for (++MARK; MARK <= SP; MARK++) {
4409             SV * const sv = newSV(0);
4410             if (*MARK)
4411                 sv_setsv(sv, *MARK);
4412             av_store(ary, AvFILLp(ary)+1, sv);
4413         }
4414         SP = ORIGMARK;
4415         PUSHi( AvFILLp(ary) + 1 );
4416     }
4417     RETURN;
4418 }
4419
4420 PP(pp_shift)
4421 {
4422     dVAR;
4423     dSP;
4424     AV * const av = (AV*)POPs;
4425     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4426     EXTEND(SP, 1);
4427     assert (sv);
4428     if (AvREAL(av))
4429         (void)sv_2mortal(sv);
4430     PUSHs(sv);
4431     RETURN;
4432 }
4433
4434 PP(pp_unshift)
4435 {
4436     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4437     register AV *ary = (AV*)*++MARK;
4438     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4439
4440     if (mg) {
4441         *MARK-- = SvTIED_obj((SV*)ary, mg);
4442         PUSHMARK(MARK);
4443         PUTBACK;
4444         ENTER;
4445         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4446         LEAVE;
4447         SPAGAIN;
4448     }
4449     else {
4450         register I32 i = 0;
4451         av_unshift(ary, SP - MARK);
4452         while (MARK < SP) {
4453             SV * const sv = newSVsv(*++MARK);
4454             (void)av_store(ary, i++, sv);
4455         }
4456     }
4457     SP = ORIGMARK;
4458     PUSHi( AvFILL(ary) + 1 );
4459     RETURN;
4460 }
4461
4462 PP(pp_reverse)
4463 {
4464     dVAR; dSP; dMARK;
4465     SV ** const oldsp = SP;
4466
4467     if (GIMME == G_ARRAY) {
4468         MARK++;
4469         while (MARK < SP) {
4470             register SV * const tmp = *MARK;
4471             *MARK++ = *SP;
4472             *SP-- = tmp;
4473         }
4474         /* safe as long as stack cannot get extended in the above */
4475         SP = oldsp;
4476     }
4477     else {
4478         register char *up;
4479         register char *down;
4480         register I32 tmp;
4481         dTARGET;
4482         STRLEN len;
4483         PADOFFSET padoff_du;
4484
4485         SvUTF8_off(TARG);                               /* decontaminate */
4486         if (SP - MARK > 1)
4487             do_join(TARG, &PL_sv_no, MARK, SP);
4488         else
4489             sv_setsv(TARG, (SP > MARK)
4490                     ? *SP
4491                     : (padoff_du = find_rundefsvoffset(),
4492                         (padoff_du == NOT_IN_PAD
4493                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4494                         ? DEFSV : PAD_SVl(padoff_du)));
4495         up = SvPV_force(TARG, len);
4496         if (len > 1) {
4497             if (DO_UTF8(TARG)) {        /* first reverse each character */
4498                 U8* s = (U8*)SvPVX(TARG);
4499                 const U8* send = (U8*)(s + len);
4500                 while (s < send) {
4501                     if (UTF8_IS_INVARIANT(*s)) {
4502                         s++;
4503                         continue;
4504                     }
4505                     else {
4506                         if (!utf8_to_uvchr(s, 0))
4507                             break;
4508                         up = (char*)s;
4509                         s += UTF8SKIP(s);
4510                         down = (char*)(s - 1);
4511                         /* reverse this character */
4512                         while (down > up) {
4513                             tmp = *up;
4514                             *up++ = *down;
4515                             *down-- = (char)tmp;
4516                         }
4517                     }
4518                 }
4519                 up = SvPVX(TARG);
4520             }
4521             down = SvPVX(TARG) + len - 1;
4522             while (down > up) {
4523                 tmp = *up;
4524                 *up++ = *down;
4525                 *down-- = (char)tmp;
4526             }
4527             (void)SvPOK_only_UTF8(TARG);
4528         }
4529         SP = MARK + 1;
4530         SETTARG;
4531     }
4532     RETURN;
4533 }
4534
4535 PP(pp_split)
4536 {
4537     dVAR; dSP; dTARG;
4538     AV *ary;
4539     register IV limit = POPi;                   /* note, negative is forever */
4540     SV * const sv = POPs;
4541     STRLEN len;
4542     register const char *s = SvPV_const(sv, len);
4543     const bool do_utf8 = DO_UTF8(sv);
4544     const char *strend = s + len;
4545     register PMOP *pm;
4546     register REGEXP *rx;
4547     register SV *dstr;
4548     register const char *m;
4549     I32 iters = 0;
4550     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4551     I32 maxiters = slen + 10;
4552     const char *orig;
4553     const I32 origlimit = limit;
4554     I32 realarray = 0;
4555     I32 base;
4556     const I32 gimme = GIMME_V;
4557     const I32 oldsave = PL_savestack_ix;
4558     I32 make_mortal = 1;
4559     bool multiline = 0;
4560     MAGIC *mg = NULL;
4561
4562 #ifdef DEBUGGING
4563     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4564 #else
4565     pm = (PMOP*)POPs;
4566 #endif
4567     if (!pm || !s)
4568         DIE(aTHX_ "panic: pp_split");
4569     rx = PM_GETRE(pm);
4570
4571     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4572              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4573
4574     RX_MATCH_UTF8_set(rx, do_utf8);
4575
4576     if (pm->op_pmreplroot) {
4577 #ifdef USE_ITHREADS
4578         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4579 #else
4580         ary = GvAVn((GV*)pm->op_pmreplroot);
4581 #endif
4582     }
4583     else if (gimme != G_ARRAY)
4584         ary = GvAVn(PL_defgv);
4585     else
4586         ary = NULL;
4587     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4588         realarray = 1;
4589         PUTBACK;
4590         av_extend(ary,0);
4591         av_clear(ary);
4592         SPAGAIN;
4593         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4594             PUSHMARK(SP);
4595             XPUSHs(SvTIED_obj((SV*)ary, mg));
4596         }
4597         else {
4598             if (!AvREAL(ary)) {
4599                 I32 i;
4600                 AvREAL_on(ary);
4601                 AvREIFY_off(ary);
4602                 for (i = AvFILLp(ary); i >= 0; i--)
4603                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4604             }
4605             /* temporarily switch stacks */
4606             SAVESWITCHSTACK(PL_curstack, ary);
4607             make_mortal = 0;
4608         }
4609     }
4610     base = SP - PL_stack_base;
4611     orig = s;
4612     if (pm->op_pmflags & PMf_SKIPWHITE) {
4613         if (do_utf8) {
4614             while (*s == ' ' || is_utf8_space((U8*)s))
4615                 s += UTF8SKIP(s);
4616         }
4617         else if (pm->op_pmflags & PMf_LOCALE) {
4618             while (isSPACE_LC(*s))
4619                 s++;
4620         }
4621         else {
4622             while (isSPACE(*s))
4623                 s++;
4624         }
4625     }
4626     if (pm->op_pmflags & PMf_MULTILINE) {
4627         multiline = 1;
4628     }
4629
4630     if (!limit)
4631         limit = maxiters + 2;
4632     if (pm->op_pmflags & PMf_WHITE) {
4633         while (--limit) {
4634             m = s;
4635             /* this one uses 'm' and is a negative test */
4636             if (do_utf8) {
4637                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4638                     const int t = UTF8SKIP(m);
4639                     /* is_utf8_space returns FALSE for malform utf8 */
4640                     if (strend - m < t)
4641                         m = strend;
4642                     else
4643                         m += t;
4644                 }
4645             } else if (pm->op_pmflags & PMf_LOCALE) {
4646                 while (m < strend && !isSPACE_LC(*m))
4647                     ++m;
4648             } else {
4649                 while (m < strend && !isSPACE(*m))
4650                     ++m;
4651             }
4652             if (m >= strend)
4653                 break;
4654
4655             dstr = newSVpvn(s, m-s);
4656             if (make_mortal)
4657                 sv_2mortal(dstr);
4658             if (do_utf8)
4659                 (void)SvUTF8_on(dstr);
4660             XPUSHs(dstr);
4661
4662             /* skip the whitespace found last */
4663             if (do_utf8)
4664                 s = m + UTF8SKIP(m);
4665             else
4666                 s = m + 1;
4667
4668             /* this one uses 's' and is a positive test */
4669             if (do_utf8) {
4670                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4671                     s +=  UTF8SKIP(s);
4672             } else if (pm->op_pmflags & PMf_LOCALE) {
4673                 while (s < strend && isSPACE_LC(*s))
4674                     ++s;
4675             } else {
4676                 while (s < strend && isSPACE(*s))
4677                     ++s;
4678             }
4679         }
4680     }
4681     else if (rx->extflags & RXf_START_ONLY) {
4682         while (--limit) {
4683             for (m = s; m < strend && *m != '\n'; m++)
4684                 ;
4685             m++;
4686             if (m >= strend)
4687                 break;
4688             dstr = newSVpvn(s, m-s);
4689             if (make_mortal)
4690                 sv_2mortal(dstr);
4691             if (do_utf8)
4692                 (void)SvUTF8_on(dstr);
4693             XPUSHs(dstr);
4694             s = m;
4695         }
4696     }
4697     else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
4698              (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
4699              && (rx->extflags & RXf_CHECK_ALL)
4700              && !(rx->extflags & RXf_ANCH)) {
4701         const int tail = (rx->extflags & RXf_INTUIT_TAIL);
4702         SV * const csv = CALLREG_INTUIT_STRING(rx);
4703
4704         len = rx->minlenret;
4705         if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
4706             const char c = *SvPV_nolen_const(csv);
4707             while (--limit) {
4708                 for (m = s; m < strend && *m != c; m++)
4709                     ;
4710                 if (m >= strend)
4711                     break;
4712                 dstr = newSVpvn(s, m-s);
4713                 if (make_mortal)
4714                     sv_2mortal(dstr);
4715                 if (do_utf8)
4716                     (void)SvUTF8_on(dstr);
4717                 XPUSHs(dstr);
4718                 /* The rx->minlen is in characters but we want to step
4719                  * s ahead by bytes. */
4720                 if (do_utf8)
4721                     s = (char*)utf8_hop((U8*)m, len);
4722                 else
4723                     s = m + len; /* Fake \n at the end */
4724             }
4725         }
4726         else {
4727             while (s < strend && --limit &&
4728               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4729                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4730             {
4731                 dstr = newSVpvn(s, m-s);
4732                 if (make_mortal)
4733                     sv_2mortal(dstr);
4734                 if (do_utf8)
4735                     (void)SvUTF8_on(dstr);
4736                 XPUSHs(dstr);
4737                 /* The rx->minlen is in characters but we want to step
4738                  * s ahead by bytes. */
4739                 if (do_utf8)
4740                     s = (char*)utf8_hop((U8*)m, len);
4741                 else
4742                     s = m + len; /* Fake \n at the end */
4743             }
4744         }
4745     }
4746     else {
4747         maxiters += slen * rx->nparens;
4748         while (s < strend && --limit)
4749         {
4750             I32 rex_return;
4751             PUTBACK;
4752             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4753                             sv, NULL, 0);
4754             SPAGAIN;
4755             if (rex_return == 0)
4756                 break;
4757             TAINT_IF(RX_MATCH_TAINTED(rx));
4758             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4759                 m = s;
4760                 s = orig;
4761                 orig = rx->subbeg;
4762                 s = orig + (m - s);
4763                 strend = s + (strend - m);
4764             }
4765             m = rx->startp[0] + orig;
4766             dstr = newSVpvn(s, m-s);
4767             if (make_mortal)
4768                 sv_2mortal(dstr);
4769             if (do_utf8)
4770                 (void)SvUTF8_on(dstr);
4771             XPUSHs(dstr);
4772             if (rx->nparens) {
4773                 I32 i;
4774                 for (i = 1; i <= (I32)rx->nparens; i++) {
4775                     s = rx->startp[i] + orig;
4776                     m = rx->endp[i] + orig;
4777
4778                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4779                        parens that didn't match -- they should be set to
4780                        undef, not the empty string */
4781                     if (m >= orig && s >= orig) {
4782                         dstr = newSVpvn(s, m-s);
4783                     }
4784                     else
4785                         dstr = &PL_sv_undef;  /* undef, not "" */
4786                     if (make_mortal)
4787                         sv_2mortal(dstr);
4788                     if (do_utf8)
4789                         (void)SvUTF8_on(dstr);
4790                     XPUSHs(dstr);
4791                 }
4792             }
4793             s = rx->endp[0] + orig;
4794         }
4795     }
4796
4797     iters = (SP - PL_stack_base) - base;
4798     if (iters > maxiters)
4799         DIE(aTHX_ "Split loop");
4800
4801     /* keep field after final delim? */
4802     if (s < strend || (iters && origlimit)) {
4803         const STRLEN l = strend - s;
4804         dstr = newSVpvn(s, l);
4805         if (make_mortal)
4806             sv_2mortal(dstr);
4807         if (do_utf8)
4808             (void)SvUTF8_on(dstr);
4809         XPUSHs(dstr);
4810         iters++;
4811     }
4812     else if (!origlimit) {
4813         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4814             if (TOPs && !make_mortal)
4815                 sv_2mortal(TOPs);
4816             iters--;
4817             *SP-- = &PL_sv_undef;
4818         }
4819     }
4820
4821     PUTBACK;
4822     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4823     SPAGAIN;
4824     if (realarray) {
4825         if (!mg) {
4826             if (SvSMAGICAL(ary)) {
4827                 PUTBACK;
4828                 mg_set((SV*)ary);
4829                 SPAGAIN;
4830             }
4831             if (gimme == G_ARRAY) {
4832                 EXTEND(SP, iters);
4833                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4834                 SP += iters;
4835                 RETURN;
4836             }
4837         }
4838         else {
4839             PUTBACK;
4840             ENTER;
4841             call_method("PUSH",G_SCALAR|G_DISCARD);
4842             LEAVE;
4843             SPAGAIN;
4844             if (gimme == G_ARRAY) {
4845                 I32 i;
4846                 /* EXTEND should not be needed - we just popped them */
4847                 EXTEND(SP, iters);
4848                 for (i=0; i < iters; i++) {
4849                     SV **svp = av_fetch(ary, i, FALSE);
4850                     PUSHs((svp) ? *svp : &PL_sv_undef);
4851                 }
4852                 RETURN;
4853             }
4854         }
4855     }
4856     else {
4857         if (gimme == G_ARRAY)
4858             RETURN;
4859     }
4860
4861     GETTARGET;
4862     PUSHi(iters);
4863     RETURN;
4864 }
4865
4866 PP(pp_lock)
4867 {
4868     dVAR;
4869     dSP;
4870     dTOPss;
4871     SV *retsv = sv;
4872     SvLOCK(sv);
4873     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4874         || SvTYPE(retsv) == SVt_PVCV) {
4875         retsv = refto(retsv);
4876     }
4877     SETs(retsv);
4878     RETURN;
4879 }
4880
4881
4882 PP(unimplemented_op)
4883 {
4884     dVAR;
4885     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4886         PL_op->op_type);
4887 }
4888
4889 /*
4890  * Local variables:
4891  * c-indentation-style: bsd
4892  * c-basic-offset: 4
4893  * indent-tabs-mode: t
4894  * End:
4895  *
4896  * ex: set ts=8 sts=4 sw=4 noet:
4897  */