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_MAX / 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 #if defined(__GLIBC__) && IVSIZE == 8
2570 STATIC
2571 PP(pp_i_modulo_0)
2572 #else
2573 PP(pp_i_modulo)
2574 #endif
2575 {
2576      /* This is the vanilla old i_modulo. */
2577      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2578      {
2579           dPOPTOPiirl;
2580           if (!right)
2581                DIE(aTHX_ "Illegal modulus zero");
2582           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2583           if (right == -1)
2584               SETi( 0 );
2585           else
2586               SETi( left % right );
2587           RETURN;
2588      }
2589 }
2590
2591 #if defined(__GLIBC__) && IVSIZE == 8
2592 STATIC
2593 PP(pp_i_modulo_1)
2594
2595 {
2596      /* This is the i_modulo with the workaround for the _moddi3 bug
2597       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2598       * See below for pp_i_modulo. */
2599      dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2600      {
2601           dPOPTOPiirl;
2602           if (!right)
2603                DIE(aTHX_ "Illegal modulus zero");
2604           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2605           if (right == -1)
2606               SETi( 0 );
2607           else
2608               SETi( left % PERL_ABS(right) );
2609           RETURN;
2610      }
2611 }
2612
2613 PP(pp_i_modulo)
2614 {
2615      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2616      {
2617           dPOPTOPiirl;
2618           if (!right)
2619                DIE(aTHX_ "Illegal modulus zero");
2620           /* The assumption is to use hereafter the old vanilla version... */
2621           PL_op->op_ppaddr =
2622                PL_ppaddr[OP_I_MODULO] =
2623                    Perl_pp_i_modulo_0;
2624           /* .. but if we have glibc, we might have a buggy _moddi3
2625            * (at least glicb 2.2.5 is known to have this bug), in other
2626            * words our integer modulus with negative quad as the second
2627            * argument might be broken.  Test for this and re-patch the
2628            * opcode dispatch table if that is the case, remembering to
2629            * also apply the workaround so that this first round works
2630            * right, too.  See [perl #9402] for more information. */
2631           {
2632                IV l =   3;
2633                IV r = -10;
2634                /* Cannot do this check with inlined IV constants since
2635                 * that seems to work correctly even with the buggy glibc. */
2636                if (l % r == -3) {
2637                     /* Yikes, we have the bug.
2638                      * Patch in the workaround version. */
2639                     PL_op->op_ppaddr =
2640                          PL_ppaddr[OP_I_MODULO] =
2641                              &Perl_pp_i_modulo_1;
2642                     /* Make certain we work right this time, too. */
2643                     right = PERL_ABS(right);
2644                }
2645           }
2646           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2647           if (right == -1)
2648               SETi( 0 );
2649           else
2650               SETi( left % right );
2651           RETURN;
2652      }
2653 }
2654 #endif
2655
2656 PP(pp_i_add)
2657 {
2658     dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2659     {
2660       dPOPTOPiirl_ul;
2661       SETi( left + right );
2662       RETURN;
2663     }
2664 }
2665
2666 PP(pp_i_subtract)
2667 {
2668     dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2669     {
2670       dPOPTOPiirl_ul;
2671       SETi( left - right );
2672       RETURN;
2673     }
2674 }
2675
2676 PP(pp_i_lt)
2677 {
2678     dVAR; dSP; tryAMAGICbinSET(lt,0);
2679     {
2680       dPOPTOPiirl;
2681       SETs(boolSV(left < right));
2682       RETURN;
2683     }
2684 }
2685
2686 PP(pp_i_gt)
2687 {
2688     dVAR; dSP; tryAMAGICbinSET(gt,0);
2689     {
2690       dPOPTOPiirl;
2691       SETs(boolSV(left > right));
2692       RETURN;
2693     }
2694 }
2695
2696 PP(pp_i_le)
2697 {
2698     dVAR; dSP; tryAMAGICbinSET(le,0);
2699     {
2700       dPOPTOPiirl;
2701       SETs(boolSV(left <= right));
2702       RETURN;
2703     }
2704 }
2705
2706 PP(pp_i_ge)
2707 {
2708     dVAR; dSP; tryAMAGICbinSET(ge,0);
2709     {
2710       dPOPTOPiirl;
2711       SETs(boolSV(left >= right));
2712       RETURN;
2713     }
2714 }
2715
2716 PP(pp_i_eq)
2717 {
2718     dVAR; dSP; tryAMAGICbinSET(eq,0);
2719     {
2720       dPOPTOPiirl;
2721       SETs(boolSV(left == right));
2722       RETURN;
2723     }
2724 }
2725
2726 PP(pp_i_ne)
2727 {
2728     dVAR; dSP; tryAMAGICbinSET(ne,0);
2729     {
2730       dPOPTOPiirl;
2731       SETs(boolSV(left != right));
2732       RETURN;
2733     }
2734 }
2735
2736 PP(pp_i_ncmp)
2737 {
2738     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2739     {
2740       dPOPTOPiirl;
2741       I32 value;
2742
2743       if (left > right)
2744         value = 1;
2745       else if (left < right)
2746         value = -1;
2747       else
2748         value = 0;
2749       SETi(value);
2750       RETURN;
2751     }
2752 }
2753
2754 PP(pp_i_negate)
2755 {
2756     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2757     SETi(-TOPi);
2758     RETURN;
2759 }
2760
2761 /* High falutin' math. */
2762
2763 PP(pp_atan2)
2764 {
2765     dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2766     {
2767       dPOPTOPnnrl;
2768       SETn(Perl_atan2(left, right));
2769       RETURN;
2770     }
2771 }
2772
2773 PP(pp_sin)
2774 {
2775     dVAR; dSP; dTARGET;
2776     int amg_type = sin_amg;
2777     const char *neg_report = NULL;
2778     NV (*func)(NV) = Perl_sin;
2779     const int op_type = PL_op->op_type;
2780
2781     switch (op_type) {
2782     case OP_COS:
2783         amg_type = cos_amg;
2784         func = Perl_cos;
2785         break;
2786     case OP_EXP:
2787         amg_type = exp_amg;
2788         func = Perl_exp;
2789         break;
2790     case OP_LOG:
2791         amg_type = log_amg;
2792         func = Perl_log;
2793         neg_report = "log";
2794         break;
2795     case OP_SQRT:
2796         amg_type = sqrt_amg;
2797         func = Perl_sqrt;
2798         neg_report = "sqrt";
2799         break;
2800     }
2801
2802     tryAMAGICun_var(amg_type);
2803     {
2804       const NV value = POPn;
2805       if (neg_report) {
2806           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2807               SET_NUMERIC_STANDARD();
2808               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2809           }
2810       }
2811       XPUSHn(func(value));
2812       RETURN;
2813     }
2814 }
2815
2816 /* Support Configure command-line overrides for rand() functions.
2817    After 5.005, perhaps we should replace this by Configure support
2818    for drand48(), random(), or rand().  For 5.005, though, maintain
2819    compatibility by calling rand() but allow the user to override it.
2820    See INSTALL for details.  --Andy Dougherty  15 July 1998
2821 */
2822 /* Now it's after 5.005, and Configure supports drand48() and random(),
2823    in addition to rand().  So the overrides should not be needed any more.
2824    --Jarkko Hietaniemi  27 September 1998
2825  */
2826
2827 #ifndef HAS_DRAND48_PROTO
2828 extern double drand48 (void);
2829 #endif
2830
2831 PP(pp_rand)
2832 {
2833     dVAR; dSP; dTARGET;
2834     NV value;
2835     if (MAXARG < 1)
2836         value = 1.0;
2837     else
2838         value = POPn;
2839     if (value == 0.0)
2840         value = 1.0;
2841     if (!PL_srand_called) {
2842         (void)seedDrand01((Rand_seed_t)seed());
2843         PL_srand_called = TRUE;
2844     }
2845     value *= Drand01();
2846     XPUSHn(value);
2847     RETURN;
2848 }
2849
2850 PP(pp_srand)
2851 {
2852     dVAR; dSP;
2853     const UV anum = (MAXARG < 1) ? seed() : POPu;
2854     (void)seedDrand01((Rand_seed_t)anum);
2855     PL_srand_called = TRUE;
2856     EXTEND(SP, 1);
2857     RETPUSHYES;
2858 }
2859
2860 PP(pp_int)
2861 {
2862     dVAR; dSP; dTARGET; tryAMAGICun(int);
2863     {
2864       const IV iv = TOPi; /* attempt to convert to IV if possible. */
2865       /* XXX it's arguable that compiler casting to IV might be subtly
2866          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2867          else preferring IV has introduced a subtle behaviour change bug. OTOH
2868          relying on floating point to be accurate is a bug.  */
2869
2870       if (!SvOK(TOPs))
2871         SETu(0);
2872       else if (SvIOK(TOPs)) {
2873         if (SvIsUV(TOPs)) {
2874             const UV uv = TOPu;
2875             SETu(uv);
2876         } else
2877             SETi(iv);
2878       } else {
2879           const NV value = TOPn;
2880           if (value >= 0.0) {
2881               if (value < (NV)UV_MAX + 0.5) {
2882                   SETu(U_V(value));
2883               } else {
2884                   SETn(Perl_floor(value));
2885               }
2886           }
2887           else {
2888               if (value > (NV)IV_MIN - 0.5) {
2889                   SETi(I_V(value));
2890               } else {
2891                   SETn(Perl_ceil(value));
2892               }
2893           }
2894       }
2895     }
2896     RETURN;
2897 }
2898
2899 PP(pp_abs)
2900 {
2901     dVAR; dSP; dTARGET; tryAMAGICun(abs);
2902     {
2903       /* This will cache the NV value if string isn't actually integer  */
2904       const IV iv = TOPi;
2905
2906       if (!SvOK(TOPs))
2907         SETu(0);
2908       else if (SvIOK(TOPs)) {
2909         /* IVX is precise  */
2910         if (SvIsUV(TOPs)) {
2911           SETu(TOPu);   /* force it to be numeric only */
2912         } else {
2913           if (iv >= 0) {
2914             SETi(iv);
2915           } else {
2916             if (iv != IV_MIN) {
2917               SETi(-iv);
2918             } else {
2919               /* 2s complement assumption. Also, not really needed as
2920                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2921               SETu(IV_MIN);
2922             }
2923           }
2924         }
2925       } else{
2926         const NV value = TOPn;
2927         if (value < 0.0)
2928           SETn(-value);
2929         else
2930           SETn(value);
2931       }
2932     }
2933     RETURN;
2934 }
2935
2936 PP(pp_oct)
2937 {
2938     dVAR; dSP; dTARGET;
2939     const char *tmps;
2940     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2941     STRLEN len;
2942     NV result_nv;
2943     UV result_uv;
2944     SV* const sv = POPs;
2945
2946     tmps = (SvPV_const(sv, len));
2947     if (DO_UTF8(sv)) {
2948          /* If Unicode, try to downgrade
2949           * If not possible, croak. */
2950          SV* const tsv = sv_2mortal(newSVsv(sv));
2951
2952          SvUTF8_on(tsv);
2953          sv_utf8_downgrade(tsv, FALSE);
2954          tmps = SvPV_const(tsv, len);
2955     }
2956     if (PL_op->op_type == OP_HEX)
2957         goto hex;
2958
2959     while (*tmps && len && isSPACE(*tmps))
2960         tmps++, len--;
2961     if (*tmps == '0')
2962         tmps++, len--;
2963     if (*tmps == 'x') {
2964     hex:
2965         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2966     }
2967     else if (*tmps == 'b')
2968         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2969     else
2970         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2971
2972     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2973         XPUSHn(result_nv);
2974     }
2975     else {
2976         XPUSHu(result_uv);
2977     }
2978     RETURN;
2979 }
2980
2981 /* String stuff. */
2982
2983 PP(pp_length)
2984 {
2985     dVAR; dSP; dTARGET;
2986     SV * const sv = TOPs;
2987
2988     if (SvAMAGIC(sv)) {
2989         /* For an overloaded scalar, we can't know in advance if it's going to
2990            be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2991            cache the length. Maybe that should be a documented feature of it.
2992         */
2993         STRLEN len;
2994         const char *const p = SvPV_const(sv, len);
2995
2996         if (DO_UTF8(sv)) {
2997             SETi(utf8_length((U8*)p, (U8*)p + len));
2998         }
2999         else
3000             SETi(len);
3001
3002     }
3003     else if (DO_UTF8(sv))
3004         SETi(sv_len_utf8(sv));
3005     else
3006         SETi(sv_len(sv));
3007     RETURN;
3008 }
3009
3010 PP(pp_substr)
3011 {
3012     dVAR; dSP; dTARGET;
3013     SV *sv;
3014     I32 len = 0;
3015     STRLEN curlen;
3016     STRLEN utf8_curlen;
3017     I32 pos;
3018     I32 rem;
3019     I32 fail;
3020     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3021     const char *tmps;
3022     const I32 arybase = CopARYBASE_get(PL_curcop);
3023     SV *repl_sv = NULL;
3024     const char *repl = NULL;
3025     STRLEN repl_len;
3026     const int num_args = PL_op->op_private & 7;
3027     bool repl_need_utf8_upgrade = FALSE;
3028     bool repl_is_utf8 = FALSE;
3029
3030     SvTAINTED_off(TARG);                        /* decontaminate */
3031     SvUTF8_off(TARG);                           /* decontaminate */
3032     if (num_args > 2) {
3033         if (num_args > 3) {
3034             repl_sv = POPs;
3035             repl = SvPV_const(repl_sv, repl_len);
3036             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3037         }
3038         len = POPi;
3039     }
3040     pos = POPi;
3041     sv = POPs;
3042     PUTBACK;
3043     if (repl_sv) {
3044         if (repl_is_utf8) {
3045             if (!DO_UTF8(sv))
3046                 sv_utf8_upgrade(sv);
3047         }
3048         else if (DO_UTF8(sv))
3049             repl_need_utf8_upgrade = TRUE;
3050     }
3051     tmps = SvPV_const(sv, curlen);
3052     if (DO_UTF8(sv)) {
3053         utf8_curlen = sv_len_utf8(sv);
3054         if (utf8_curlen == curlen)
3055             utf8_curlen = 0;
3056         else
3057             curlen = utf8_curlen;
3058     }
3059     else
3060         utf8_curlen = 0;
3061
3062     if (pos >= arybase) {
3063         pos -= arybase;
3064         rem = curlen-pos;
3065         fail = rem;
3066         if (num_args > 2) {
3067             if (len < 0) {
3068                 rem += len;
3069                 if (rem < 0)
3070                     rem = 0;
3071             }
3072             else if (rem > len)
3073                      rem = len;
3074         }
3075     }
3076     else {
3077         pos += curlen;
3078         if (num_args < 3)
3079             rem = curlen;
3080         else if (len >= 0) {
3081             rem = pos+len;
3082             if (rem > (I32)curlen)
3083                 rem = curlen;
3084         }
3085         else {
3086             rem = curlen+len;
3087             if (rem < pos)
3088                 rem = pos;
3089         }
3090         if (pos < 0)
3091             pos = 0;
3092         fail = rem;
3093         rem -= pos;
3094     }
3095     if (fail < 0) {
3096         if (lvalue || repl)
3097             Perl_croak(aTHX_ "substr outside of string");
3098         if (ckWARN(WARN_SUBSTR))
3099             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3100         RETPUSHUNDEF;
3101     }
3102     else {
3103         const I32 upos = pos;
3104         const I32 urem = rem;
3105         if (utf8_curlen)
3106             sv_pos_u2b(sv, &pos, &rem);
3107         tmps += pos;
3108         /* we either return a PV or an LV. If the TARG hasn't been used
3109          * before, or is of that type, reuse it; otherwise use a mortal
3110          * instead. Note that LVs can have an extended lifetime, so also
3111          * dont reuse if refcount > 1 (bug #20933) */
3112         if (SvTYPE(TARG) > SVt_NULL) {
3113             if ( (SvTYPE(TARG) == SVt_PVLV)
3114                     ? (!lvalue || SvREFCNT(TARG) > 1)
3115                     : lvalue)
3116             {
3117                 TARG = sv_newmortal();
3118             }
3119         }
3120
3121         sv_setpvn(TARG, tmps, rem);
3122 #ifdef USE_LOCALE_COLLATE
3123         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3124 #endif
3125         if (utf8_curlen)
3126             SvUTF8_on(TARG);
3127         if (repl) {
3128             SV* repl_sv_copy = NULL;
3129
3130             if (repl_need_utf8_upgrade) {
3131                 repl_sv_copy = newSVsv(repl_sv);
3132                 sv_utf8_upgrade(repl_sv_copy);
3133                 repl = SvPV_const(repl_sv_copy, repl_len);
3134                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3135             }
3136             sv_insert(sv, pos, rem, repl, repl_len);
3137             if (repl_is_utf8)
3138                 SvUTF8_on(sv);
3139             if (repl_sv_copy)
3140                 SvREFCNT_dec(repl_sv_copy);
3141         }
3142         else if (lvalue) {              /* it's an lvalue! */
3143             if (!SvGMAGICAL(sv)) {
3144                 if (SvROK(sv)) {
3145                     SvPV_force_nolen(sv);
3146                     if (ckWARN(WARN_SUBSTR))
3147                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3148                                 "Attempt to use reference as lvalue in substr");
3149                 }
3150                 if (isGV_with_GP(sv))
3151                     SvPV_force_nolen(sv);
3152                 else if (SvOK(sv))      /* is it defined ? */
3153                     (void)SvPOK_only_UTF8(sv);
3154                 else
3155                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3156             }
3157
3158             if (SvTYPE(TARG) < SVt_PVLV) {
3159                 sv_upgrade(TARG, SVt_PVLV);
3160                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3161             }
3162
3163             LvTYPE(TARG) = 'x';
3164             if (LvTARG(TARG) != sv) {
3165                 if (LvTARG(TARG))
3166                     SvREFCNT_dec(LvTARG(TARG));
3167                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3168             }
3169             LvTARGOFF(TARG) = upos;
3170             LvTARGLEN(TARG) = urem;
3171         }
3172     }
3173     SPAGAIN;
3174     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3175     RETURN;
3176 }
3177
3178 PP(pp_vec)
3179 {
3180     dVAR; dSP; dTARGET;
3181     register const IV size   = POPi;
3182     register const IV offset = POPi;
3183     register SV * const src = POPs;
3184     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3185
3186     SvTAINTED_off(TARG);                /* decontaminate */
3187     if (lvalue) {                       /* it's an lvalue! */
3188         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3189             TARG = sv_newmortal();
3190         if (SvTYPE(TARG) < SVt_PVLV) {
3191             sv_upgrade(TARG, SVt_PVLV);
3192             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3193         }
3194         LvTYPE(TARG) = 'v';
3195         if (LvTARG(TARG) != src) {
3196             if (LvTARG(TARG))
3197                 SvREFCNT_dec(LvTARG(TARG));
3198             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3199         }
3200         LvTARGOFF(TARG) = offset;
3201         LvTARGLEN(TARG) = size;
3202     }
3203
3204     sv_setuv(TARG, do_vecget(src, offset, size));
3205     PUSHs(TARG);
3206     RETURN;
3207 }
3208
3209 PP(pp_index)
3210 {
3211     dVAR; dSP; dTARGET;
3212     SV *big;
3213     SV *little;
3214     SV *temp = NULL;
3215     STRLEN biglen;
3216     STRLEN llen = 0;
3217     I32 offset;
3218     I32 retval;
3219     const char *big_p;
3220     const char *little_p;
3221     const I32 arybase = CopARYBASE_get(PL_curcop);
3222     bool big_utf8;
3223     bool little_utf8;
3224     const bool is_index = PL_op->op_type == OP_INDEX;
3225
3226     if (MAXARG >= 3) {
3227         /* arybase is in characters, like offset, so combine prior to the
3228            UTF-8 to bytes calculation.  */
3229         offset = POPi - arybase;
3230     }
3231     little = POPs;
3232     big = POPs;
3233     big_p = SvPV_const(big, biglen);
3234     little_p = SvPV_const(little, llen);
3235
3236     big_utf8 = DO_UTF8(big);
3237     little_utf8 = DO_UTF8(little);
3238     if (big_utf8 ^ little_utf8) {
3239         /* One needs to be upgraded.  */
3240         if (little_utf8 && !PL_encoding) {
3241             /* Well, maybe instead we might be able to downgrade the small
3242                string?  */
3243             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3244                                                      &little_utf8);
3245             if (little_utf8) {
3246                 /* If the large string is ISO-8859-1, and it's not possible to
3247                    convert the small string to ISO-8859-1, then there is no
3248                    way that it could be found anywhere by index.  */
3249                 retval = -1;
3250                 goto fail;
3251             }
3252
3253             /* At this point, pv is a malloc()ed string. So donate it to temp
3254                to ensure it will get free()d  */
3255             little = temp = newSV(0);
3256             sv_usepvn(temp, pv, llen);
3257             little_p = SvPVX(little);
3258         } else {
3259             temp = little_utf8
3260                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3261
3262             if (PL_encoding) {
3263                 sv_recode_to_utf8(temp, PL_encoding);
3264             } else {
3265                 sv_utf8_upgrade(temp);
3266             }
3267             if (little_utf8) {
3268                 big = temp;
3269                 big_utf8 = TRUE;
3270                 big_p = SvPV_const(big, biglen);
3271             } else {
3272                 little = temp;
3273                 little_p = SvPV_const(little, llen);
3274             }
3275         }
3276     }
3277     if (SvGAMAGIC(big)) {
3278         /* Life just becomes a lot easier if I use a temporary here.
3279            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3280            will trigger magic and overloading again, as will fbm_instr()
3281         */
3282         big = sv_2mortal(newSVpvn(big_p, biglen));
3283         if (big_utf8)
3284             SvUTF8_on(big);
3285         big_p = SvPVX(big);
3286     }
3287     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3288         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3289            warn on undef, and we've already triggered a warning with the
3290            SvPV_const some lines above. We can't remove that, as we need to
3291            call some SvPV to trigger overloading early and find out if the
3292            string is UTF-8.
3293            This is all getting to messy. The API isn't quite clean enough,
3294            because data access has side effects.
3295         */
3296         little = sv_2mortal(newSVpvn(little_p, llen));
3297         if (little_utf8)
3298             SvUTF8_on(little);
3299         little_p = SvPVX(little);
3300     }
3301
3302     if (MAXARG < 3)
3303         offset = is_index ? 0 : biglen;
3304     else {
3305         if (big_utf8 && offset > 0)
3306             sv_pos_u2b(big, &offset, 0);
3307         if (!is_index)
3308             offset += llen;
3309     }
3310     if (offset < 0)
3311         offset = 0;
3312     else if (offset > (I32)biglen)
3313         offset = biglen;
3314     if (!(little_p = is_index
3315           ? fbm_instr((unsigned char*)big_p + offset,
3316                       (unsigned char*)big_p + biglen, little, 0)
3317           : rninstr(big_p,  big_p  + offset,
3318                     little_p, little_p + llen)))
3319         retval = -1;
3320     else {
3321         retval = little_p - big_p;
3322         if (retval > 0 && big_utf8)
3323             sv_pos_b2u(big, &retval);
3324     }
3325     if (temp)
3326         SvREFCNT_dec(temp);
3327  fail:
3328     PUSHi(retval + arybase);
3329     RETURN;
3330 }
3331
3332 PP(pp_sprintf)
3333 {
3334     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3335     if (SvTAINTED(MARK[1]))
3336         TAINT_PROPER("sprintf");
3337     do_sprintf(TARG, SP-MARK, MARK+1);
3338     TAINT_IF(SvTAINTED(TARG));
3339     SP = ORIGMARK;
3340     PUSHTARG;
3341     RETURN;
3342 }
3343
3344 PP(pp_ord)
3345 {
3346     dVAR; dSP; dTARGET;
3347
3348     SV *argsv = POPs;
3349     STRLEN len;
3350     const U8 *s = (U8*)SvPV_const(argsv, len);
3351
3352     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3353         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3354         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3355         argsv = tmpsv;
3356     }
3357
3358     XPUSHu(DO_UTF8(argsv) ?
3359            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3360            (UV)(*s & 0xff));
3361
3362     RETURN;
3363 }
3364
3365 PP(pp_chr)
3366 {
3367     dVAR; dSP; dTARGET;
3368     char *tmps;
3369     UV value;
3370
3371     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3372          ||
3373          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3374         if (IN_BYTES) {
3375             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3376         } else {
3377             (void) POPs; /* Ignore the argument value. */
3378             value = UNICODE_REPLACEMENT;
3379         }
3380     } else {
3381         value = POPu;
3382     }
3383
3384     SvUPGRADE(TARG,SVt_PV);
3385
3386     if (value > 255 && !IN_BYTES) {
3387         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3388         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3389         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3390         *tmps = '\0';
3391         (void)SvPOK_only(TARG);
3392         SvUTF8_on(TARG);
3393         XPUSHs(TARG);
3394         RETURN;
3395     }
3396
3397     SvGROW(TARG,2);
3398     SvCUR_set(TARG, 1);
3399     tmps = SvPVX(TARG);
3400     *tmps++ = (char)value;
3401     *tmps = '\0';
3402     (void)SvPOK_only(TARG);
3403
3404     if (PL_encoding && !IN_BYTES) {
3405         sv_recode_to_utf8(TARG, PL_encoding);
3406         tmps = SvPVX(TARG);
3407         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3408             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3409             SvGROW(TARG, 2);
3410             tmps = SvPVX(TARG);
3411             SvCUR_set(TARG, 1);
3412             *tmps++ = (char)value;
3413             *tmps = '\0';
3414             SvUTF8_off(TARG);
3415         }
3416     }
3417
3418     XPUSHs(TARG);
3419     RETURN;
3420 }
3421
3422 PP(pp_crypt)
3423 {
3424 #ifdef HAS_CRYPT
3425     dVAR; dSP; dTARGET;
3426     dPOPTOPssrl;
3427     STRLEN len;
3428     const char *tmps = SvPV_const(left, len);
3429
3430     if (DO_UTF8(left)) {
3431          /* If Unicode, try to downgrade.
3432           * If not possible, croak.
3433           * Yes, we made this up.  */
3434          SV* const tsv = sv_2mortal(newSVsv(left));
3435
3436          SvUTF8_on(tsv);
3437          sv_utf8_downgrade(tsv, FALSE);
3438          tmps = SvPV_const(tsv, len);
3439     }
3440 #   ifdef USE_ITHREADS
3441 #     ifdef HAS_CRYPT_R
3442     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3443       /* This should be threadsafe because in ithreads there is only
3444        * one thread per interpreter.  If this would not be true,
3445        * we would need a mutex to protect this malloc. */
3446         PL_reentrant_buffer->_crypt_struct_buffer =
3447           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3448 #if defined(__GLIBC__) || defined(__EMX__)
3449         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3450             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3451             /* work around glibc-2.2.5 bug */
3452             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3453         }
3454 #endif
3455     }
3456 #     endif /* HAS_CRYPT_R */
3457 #   endif /* USE_ITHREADS */
3458 #   ifdef FCRYPT
3459     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3460 #   else
3461     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3462 #   endif
3463     SETs(TARG);
3464     RETURN;
3465 #else
3466     DIE(aTHX_
3467       "The crypt() function is unimplemented due to excessive paranoia.");
3468 #endif
3469 }
3470
3471 PP(pp_ucfirst)
3472 {
3473     dVAR;
3474     dSP;
3475     SV *source = TOPs;
3476     STRLEN slen;
3477     STRLEN need;
3478     SV *dest;
3479     bool inplace = TRUE;
3480     bool doing_utf8;
3481     const int op_type = PL_op->op_type;
3482     const U8 *s;
3483     U8 *d;
3484     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3485     STRLEN ulen;
3486     STRLEN tculen;
3487
3488     SvGETMAGIC(source);
3489     if (SvOK(source)) {
3490         s = (const U8*)SvPV_nomg_const(source, slen);
3491     } else {
3492         s = (const U8*)"";
3493         slen = 0;
3494     }
3495
3496     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3497         doing_utf8 = TRUE;
3498         utf8_to_uvchr(s, &ulen);
3499         if (op_type == OP_UCFIRST) {
3500             toTITLE_utf8(s, tmpbuf, &tculen);
3501         } else {
3502             toLOWER_utf8(s, tmpbuf, &tculen);
3503         }
3504         /* If the two differ, we definately cannot do inplace.  */
3505         inplace = (ulen == tculen);
3506         need = slen + 1 - ulen + tculen;
3507     } else {
3508         doing_utf8 = FALSE;
3509         need = slen + 1;
3510     }
3511
3512     if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3513         /* We can convert in place.  */
3514
3515         dest = source;
3516         s = d = (U8*)SvPV_force_nomg(source, slen);
3517     } else {
3518         dTARGET;
3519
3520         dest = TARG;
3521
3522         SvUPGRADE(dest, SVt_PV);
3523         d = (U8*)SvGROW(dest, need);
3524         (void)SvPOK_only(dest);
3525
3526         SETs(dest);
3527
3528         inplace = FALSE;
3529     }
3530
3531     if (doing_utf8) {
3532         if(!inplace) {
3533             /* slen is the byte length of the whole SV.
3534              * ulen is the byte length of the original Unicode character
3535              * stored as UTF-8 at s.
3536              * tculen is the byte length of the freshly titlecased (or
3537              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3538              * We first set the result to be the titlecased (/lowercased)
3539              * character, and then append the rest of the SV data. */
3540             sv_setpvn(dest, (char*)tmpbuf, tculen);
3541             if (slen > ulen)
3542                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3543             SvUTF8_on(dest);
3544         }
3545         else {
3546             Copy(tmpbuf, d, tculen, U8);
3547             SvCUR_set(dest, need - 1);
3548         }
3549     }
3550     else {
3551         if (*s) {
3552             if (IN_LOCALE_RUNTIME) {
3553                 TAINT;
3554                 SvTAINTED_on(dest);
3555                 *d = (op_type == OP_UCFIRST)
3556                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3557             }
3558             else
3559                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3560         } else {
3561             /* See bug #39028  */
3562             *d = *s;
3563         }
3564
3565         if (SvUTF8(source))
3566             SvUTF8_on(dest);
3567
3568         if (!inplace) {
3569             /* This will copy the trailing NUL  */
3570             Copy(s + 1, d + 1, slen, U8);
3571             SvCUR_set(dest, need - 1);
3572         }
3573     }
3574     SvSETMAGIC(dest);
3575     RETURN;
3576 }
3577
3578 /* There's so much setup/teardown code common between uc and lc, I wonder if
3579    it would be worth merging the two, and just having a switch outside each
3580    of the three tight loops.  */
3581 PP(pp_uc)
3582 {
3583     dVAR;
3584     dSP;
3585     SV *source = TOPs;
3586     STRLEN len;
3587     STRLEN min;
3588     SV *dest;
3589     const U8 *s;
3590     U8 *d;
3591
3592     SvGETMAGIC(source);
3593
3594     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3595         && !DO_UTF8(source)) {
3596         /* We can convert in place.  */
3597
3598         dest = source;
3599         s = d = (U8*)SvPV_force_nomg(source, len);
3600         min = len + 1;
3601     } else {
3602         dTARGET;
3603
3604         dest = TARG;
3605
3606         /* The old implementation would copy source into TARG at this point.
3607            This had the side effect that if source was undef, TARG was now
3608            an undefined SV with PADTMP set, and they don't warn inside
3609            sv_2pv_flags(). However, we're now getting the PV direct from
3610            source, which doesn't have PADTMP set, so it would warn. Hence the
3611            little games.  */
3612
3613         if (SvOK(source)) {
3614             s = (const U8*)SvPV_nomg_const(source, len);
3615         } else {
3616             s = (const U8*)"";
3617             len = 0;
3618         }
3619         min = len + 1;
3620
3621         SvUPGRADE(dest, SVt_PV);
3622         d = (U8*)SvGROW(dest, min);
3623         (void)SvPOK_only(dest);
3624
3625         SETs(dest);
3626     }
3627
3628     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3629        to check DO_UTF8 again here.  */
3630
3631     if (DO_UTF8(source)) {
3632         const U8 *const send = s + len;
3633         U8 tmpbuf[UTF8_MAXBYTES+1];
3634
3635         while (s < send) {
3636             const STRLEN u = UTF8SKIP(s);
3637             STRLEN ulen;
3638
3639             toUPPER_utf8(s, tmpbuf, &ulen);
3640             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3641                 /* If the eventually required minimum size outgrows
3642                  * the available space, we need to grow. */
3643                 const UV o = d - (U8*)SvPVX_const(dest);
3644
3645                 /* If someone uppercases one million U+03B0s we SvGROW() one
3646                  * million times.  Or we could try guessing how much to
3647                  allocate without allocating too much.  Such is life. */
3648                 SvGROW(dest, min);
3649                 d = (U8*)SvPVX(dest) + o;
3650             }
3651             Copy(tmpbuf, d, ulen, U8);
3652             d += ulen;
3653             s += u;
3654         }
3655         SvUTF8_on(dest);
3656         *d = '\0';
3657         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3658     } else {
3659         if (len) {
3660             const U8 *const send = s + len;
3661             if (IN_LOCALE_RUNTIME) {
3662                 TAINT;
3663                 SvTAINTED_on(dest);
3664                 for (; s < send; d++, s++)
3665                     *d = toUPPER_LC(*s);
3666             }
3667             else {
3668                 for (; s < send; d++, s++)
3669                     *d = toUPPER(*s);
3670             }
3671         }
3672         if (source != dest) {
3673             *d = '\0';
3674             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3675         }
3676     }
3677     SvSETMAGIC(dest);
3678     RETURN;
3679 }
3680
3681 PP(pp_lc)
3682 {
3683     dVAR;
3684     dSP;
3685     SV *source = TOPs;
3686     STRLEN len;
3687     STRLEN min;
3688     SV *dest;
3689     const U8 *s;
3690     U8 *d;
3691
3692     SvGETMAGIC(source);
3693
3694     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3695         && !DO_UTF8(source)) {
3696         /* We can convert in place.  */
3697
3698         dest = source;
3699         s = d = (U8*)SvPV_force_nomg(source, len);
3700         min = len + 1;
3701     } else {
3702         dTARGET;
3703
3704         dest = TARG;
3705
3706         /* The old implementation would copy source into TARG at this point.
3707            This had the side effect that if source was undef, TARG was now
3708            an undefined SV with PADTMP set, and they don't warn inside
3709            sv_2pv_flags(). However, we're now getting the PV direct from
3710            source, which doesn't have PADTMP set, so it would warn. Hence the
3711            little games.  */
3712
3713         if (SvOK(source)) {
3714             s = (const U8*)SvPV_nomg_const(source, len);
3715         } else {
3716             s = (const U8*)"";
3717             len = 0;
3718         }
3719         min = len + 1;
3720
3721         SvUPGRADE(dest, SVt_PV);
3722         d = (U8*)SvGROW(dest, min);
3723         (void)SvPOK_only(dest);
3724
3725         SETs(dest);
3726     }
3727
3728     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3729        to check DO_UTF8 again here.  */
3730
3731     if (DO_UTF8(source)) {
3732         const U8 *const send = s + len;
3733         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3734
3735         while (s < send) {
3736             const STRLEN u = UTF8SKIP(s);
3737             STRLEN ulen;
3738             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3739
3740 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3741             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3742                 NOOP;
3743                 /*
3744                  * Now if the sigma is NOT followed by
3745                  * /$ignorable_sequence$cased_letter/;
3746                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3747                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3748                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3749                  * then it should be mapped to 0x03C2,
3750                  * (GREEK SMALL LETTER FINAL SIGMA),
3751                  * instead of staying 0x03A3.
3752                  * "should be": in other words, this is not implemented yet.
3753                  * See lib/unicore/SpecialCasing.txt.
3754                  */
3755             }
3756             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3757                 /* If the eventually required minimum size outgrows
3758                  * the available space, we need to grow. */
3759                 const UV o = d - (U8*)SvPVX_const(dest);
3760
3761                 /* If someone lowercases one million U+0130s we SvGROW() one
3762                  * million times.  Or we could try guessing how much to
3763                  allocate without allocating too much.  Such is life. */
3764                 SvGROW(dest, min);
3765                 d = (U8*)SvPVX(dest) + o;
3766             }
3767             Copy(tmpbuf, d, ulen, U8);
3768             d += ulen;
3769             s += u;
3770         }
3771         SvUTF8_on(dest);
3772         *d = '\0';
3773         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3774     } else {
3775         if (len) {
3776             const U8 *const send = s + len;
3777             if (IN_LOCALE_RUNTIME) {
3778                 TAINT;
3779                 SvTAINTED_on(dest);
3780                 for (; s < send; d++, s++)
3781                     *d = toLOWER_LC(*s);
3782             }
3783             else {
3784                 for (; s < send; d++, s++)
3785                     *d = toLOWER(*s);
3786             }
3787         }
3788         if (source != dest) {
3789             *d = '\0';
3790             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3791         }
3792     }
3793     SvSETMAGIC(dest);
3794     RETURN;
3795 }
3796
3797 PP(pp_quotemeta)
3798 {
3799     dVAR; dSP; dTARGET;
3800     SV * const sv = TOPs;
3801     STRLEN len;
3802     register const char *s = SvPV_const(sv,len);
3803
3804     SvUTF8_off(TARG);                           /* decontaminate */
3805     if (len) {
3806         register char *d;
3807         SvUPGRADE(TARG, SVt_PV);
3808         SvGROW(TARG, (len * 2) + 1);
3809         d = SvPVX(TARG);
3810         if (DO_UTF8(sv)) {
3811             while (len) {
3812                 if (UTF8_IS_CONTINUED(*s)) {
3813                     STRLEN ulen = UTF8SKIP(s);
3814                     if (ulen > len)
3815                         ulen = len;
3816                     len -= ulen;
3817                     while (ulen--)
3818                         *d++ = *s++;
3819                 }
3820                 else {
3821                     if (!isALNUM(*s))
3822                         *d++ = '\\';
3823                     *d++ = *s++;
3824                     len--;
3825                 }
3826             }
3827             SvUTF8_on(TARG);
3828         }
3829         else {
3830             while (len--) {
3831                 if (!isALNUM(*s))
3832                     *d++ = '\\';
3833                 *d++ = *s++;
3834             }
3835         }
3836         *d = '\0';
3837         SvCUR_set(TARG, d - SvPVX_const(TARG));
3838         (void)SvPOK_only_UTF8(TARG);
3839     }
3840     else
3841         sv_setpvn(TARG, s, len);
3842     SETs(TARG);
3843     if (SvSMAGICAL(TARG))
3844         mg_set(TARG);
3845     RETURN;
3846 }
3847
3848 /* Arrays. */
3849
3850 PP(pp_aslice)
3851 {
3852     dVAR; dSP; dMARK; dORIGMARK;
3853     register AV* const av = (AV*)POPs;
3854     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3855
3856     if (SvTYPE(av) == SVt_PVAV) {
3857         const I32 arybase = CopARYBASE_get(PL_curcop);
3858         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3859             register SV **svp;
3860             I32 max = -1;
3861             for (svp = MARK + 1; svp <= SP; svp++) {
3862                 const I32 elem = SvIVx(*svp);
3863                 if (elem > max)
3864                     max = elem;
3865             }
3866             if (max > AvMAX(av))
3867                 av_extend(av, max);
3868         }
3869         while (++MARK <= SP) {
3870             register SV **svp;
3871             I32 elem = SvIVx(*MARK);
3872
3873             if (elem > 0)
3874                 elem -= arybase;
3875             svp = av_fetch(av, elem, lval);
3876             if (lval) {
3877                 if (!svp || *svp == &PL_sv_undef)
3878                     DIE(aTHX_ PL_no_aelem, elem);
3879                 if (PL_op->op_private & OPpLVAL_INTRO)
3880                     save_aelem(av, elem, svp);
3881             }
3882             *MARK = svp ? *svp : &PL_sv_undef;
3883         }
3884     }
3885     if (GIMME != G_ARRAY) {
3886         MARK = ORIGMARK;
3887         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3888         SP = MARK;
3889     }
3890     RETURN;
3891 }
3892
3893 /* Associative arrays. */
3894
3895 PP(pp_each)
3896 {
3897     dVAR;
3898     dSP;
3899     HV * hash = (HV*)POPs;
3900     HE *entry;
3901     const I32 gimme = GIMME_V;
3902
3903     PUTBACK;
3904     /* might clobber stack_sp */
3905     entry = hv_iternext(hash);
3906     SPAGAIN;
3907
3908     EXTEND(SP, 2);
3909     if (entry) {
3910         SV* const sv = hv_iterkeysv(entry);
3911         PUSHs(sv);      /* won't clobber stack_sp */
3912         if (gimme == G_ARRAY) {
3913             SV *val;
3914             PUTBACK;
3915             /* might clobber stack_sp */
3916             val = hv_iterval(hash, entry);
3917             SPAGAIN;
3918             PUSHs(val);
3919         }
3920     }
3921     else if (gimme == G_SCALAR)
3922         RETPUSHUNDEF;
3923
3924     RETURN;
3925 }
3926
3927 PP(pp_delete)
3928 {
3929     dVAR;
3930     dSP;
3931     const I32 gimme = GIMME_V;
3932     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3933
3934     if (PL_op->op_private & OPpSLICE) {
3935         dMARK; dORIGMARK;
3936         HV * const hv = (HV*)POPs;
3937         const U32 hvtype = SvTYPE(hv);
3938         if (hvtype == SVt_PVHV) {                       /* hash element */
3939             while (++MARK <= SP) {
3940                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3941                 *MARK = sv ? sv : &PL_sv_undef;
3942             }
3943         }
3944         else if (hvtype == SVt_PVAV) {                  /* array element */
3945             if (PL_op->op_flags & OPf_SPECIAL) {
3946                 while (++MARK <= SP) {
3947                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3948                     *MARK = sv ? sv : &PL_sv_undef;
3949                 }
3950             }
3951         }
3952         else
3953             DIE(aTHX_ "Not a HASH reference");
3954         if (discard)
3955             SP = ORIGMARK;
3956         else if (gimme == G_SCALAR) {
3957             MARK = ORIGMARK;
3958             if (SP > MARK)
3959                 *++MARK = *SP;
3960             else
3961                 *++MARK = &PL_sv_undef;
3962             SP = MARK;
3963         }
3964     }
3965     else {
3966         SV *keysv = POPs;
3967         HV * const hv = (HV*)POPs;
3968         SV *sv;
3969         if (SvTYPE(hv) == SVt_PVHV)
3970             sv = hv_delete_ent(hv, keysv, discard, 0);
3971         else if (SvTYPE(hv) == SVt_PVAV) {
3972             if (PL_op->op_flags & OPf_SPECIAL)
3973                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3974             else
3975                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3976         }
3977         else
3978             DIE(aTHX_ "Not a HASH reference");
3979         if (!sv)
3980             sv = &PL_sv_undef;
3981         if (!discard)
3982             PUSHs(sv);
3983     }
3984     RETURN;
3985 }
3986
3987 PP(pp_exists)
3988 {
3989     dVAR;
3990     dSP;
3991     SV *tmpsv;
3992     HV *hv;
3993
3994     if (PL_op->op_private & OPpEXISTS_SUB) {
3995         GV *gv;
3996         SV * const sv = POPs;
3997         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3998         if (cv)
3999             RETPUSHYES;
4000         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4001             RETPUSHYES;
4002         RETPUSHNO;
4003     }
4004     tmpsv = POPs;
4005     hv = (HV*)POPs;
4006     if (SvTYPE(hv) == SVt_PVHV) {
4007         if (hv_exists_ent(hv, tmpsv, 0))
4008             RETPUSHYES;
4009     }
4010     else if (SvTYPE(hv) == SVt_PVAV) {
4011         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4012             if (av_exists((AV*)hv, SvIV(tmpsv)))
4013                 RETPUSHYES;
4014         }
4015     }
4016     else {
4017         DIE(aTHX_ "Not a HASH reference");
4018     }
4019     RETPUSHNO;
4020 }
4021
4022 PP(pp_hslice)
4023 {
4024     dVAR; dSP; dMARK; dORIGMARK;
4025     register HV * const hv = (HV*)POPs;
4026     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4027     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4028     bool other_magic = FALSE;
4029
4030     if (localizing) {
4031         MAGIC *mg;
4032         HV *stash;
4033
4034         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4035             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4036              /* Try to preserve the existenceness of a tied hash
4037               * element by using EXISTS and DELETE if possible.
4038               * Fallback to FETCH and STORE otherwise */
4039              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4040              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4041              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4042     }
4043
4044     while (++MARK <= SP) {
4045         SV * const keysv = *MARK;
4046         SV **svp;
4047         HE *he;
4048         bool preeminent = FALSE;
4049
4050         if (localizing) {
4051             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4052                 hv_exists_ent(hv, keysv, 0);
4053         }
4054
4055         he = hv_fetch_ent(hv, keysv, lval, 0);
4056         svp = he ? &HeVAL(he) : 0;
4057
4058         if (lval) {
4059             if (!svp || *svp == &PL_sv_undef) {
4060                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4061             }
4062             if (localizing) {
4063                 if (HvNAME_get(hv) && isGV(*svp))
4064                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4065                 else {
4066                     if (preeminent)
4067                         save_helem(hv, keysv, svp);
4068                     else {
4069                         STRLEN keylen;
4070                         const char * const key = SvPV_const(keysv, keylen);
4071                         SAVEDELETE(hv, savepvn(key,keylen),
4072                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4073                     }
4074                 }
4075             }
4076         }
4077         *MARK = svp ? *svp : &PL_sv_undef;
4078     }
4079     if (GIMME != G_ARRAY) {
4080         MARK = ORIGMARK;
4081         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4082         SP = MARK;
4083     }
4084     RETURN;
4085 }
4086
4087 /* List operators. */
4088
4089 PP(pp_list)
4090 {
4091     dVAR; dSP; dMARK;
4092     if (GIMME != G_ARRAY) {
4093         if (++MARK <= SP)
4094             *MARK = *SP;                /* unwanted list, return last item */
4095         else
4096             *MARK = &PL_sv_undef;
4097         SP = MARK;
4098     }
4099     RETURN;
4100 }
4101
4102 PP(pp_lslice)
4103 {
4104     dVAR;
4105     dSP;
4106     SV ** const lastrelem = PL_stack_sp;
4107     SV ** const lastlelem = PL_stack_base + POPMARK;
4108     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4109     register SV ** const firstrelem = lastlelem + 1;
4110     const I32 arybase = CopARYBASE_get(PL_curcop);
4111     I32 is_something_there = FALSE;
4112
4113     register const I32 max = lastrelem - lastlelem;
4114     register SV **lelem;
4115
4116     if (GIMME != G_ARRAY) {
4117         I32 ix = SvIVx(*lastlelem);
4118         if (ix < 0)
4119             ix += max;
4120         else
4121             ix -= arybase;
4122         if (ix < 0 || ix >= max)
4123             *firstlelem = &PL_sv_undef;
4124         else
4125             *firstlelem = firstrelem[ix];
4126         SP = firstlelem;
4127         RETURN;
4128     }
4129
4130     if (max == 0) {
4131         SP = firstlelem - 1;
4132         RETURN;
4133     }
4134
4135     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4136         I32 ix = SvIVx(*lelem);
4137         if (ix < 0)
4138             ix += max;
4139         else
4140             ix -= arybase;
4141         if (ix < 0 || ix >= max)
4142             *lelem = &PL_sv_undef;
4143         else {
4144             is_something_there = TRUE;
4145             if (!(*lelem = firstrelem[ix]))
4146                 *lelem = &PL_sv_undef;
4147         }
4148     }
4149     if (is_something_there)
4150         SP = lastlelem;
4151     else
4152         SP = firstlelem - 1;
4153     RETURN;
4154 }
4155
4156 PP(pp_anonlist)
4157 {
4158     dVAR; dSP; dMARK; dORIGMARK;
4159     const I32 items = SP - MARK;
4160     SV * const av = (SV *) av_make(items, MARK+1);
4161     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4162     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4163                       ? newRV_noinc(av) : av));
4164     RETURN;
4165 }
4166
4167 PP(pp_anonhash)
4168 {
4169     dVAR; dSP; dMARK; dORIGMARK;
4170     HV* const hv = newHV();
4171
4172     while (MARK < SP) {
4173         SV * const key = *++MARK;
4174         SV * const val = newSV(0);
4175         if (MARK < SP)
4176             sv_setsv(val, *++MARK);
4177         else if (ckWARN(WARN_MISC))
4178             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4179         (void)hv_store_ent(hv,key,val,0);
4180     }
4181     SP = ORIGMARK;
4182     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4183                       ? newRV_noinc((SV*) hv) : (SV*)hv));
4184     RETURN;
4185 }
4186
4187 PP(pp_splice)
4188 {
4189     dVAR; dSP; dMARK; dORIGMARK;
4190     register AV *ary = (AV*)*++MARK;
4191     register SV **src;
4192     register SV **dst;
4193     register I32 i;
4194     register I32 offset;
4195     register I32 length;
4196     I32 newlen;
4197     I32 after;
4198     I32 diff;
4199     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4200
4201     if (mg) {
4202         *MARK-- = SvTIED_obj((SV*)ary, mg);
4203         PUSHMARK(MARK);
4204         PUTBACK;
4205         ENTER;
4206         call_method("SPLICE",GIMME_V);
4207         LEAVE;
4208         SPAGAIN;
4209         RETURN;
4210     }
4211
4212     SP++;
4213
4214     if (++MARK < SP) {
4215         offset = i = SvIVx(*MARK);
4216         if (offset < 0)
4217             offset += AvFILLp(ary) + 1;
4218         else
4219             offset -= CopARYBASE_get(PL_curcop);
4220         if (offset < 0)
4221             DIE(aTHX_ PL_no_aelem, i);
4222         if (++MARK < SP) {
4223             length = SvIVx(*MARK++);
4224             if (length < 0) {
4225                 length += AvFILLp(ary) - offset + 1;
4226                 if (length < 0)
4227                     length = 0;
4228             }
4229         }
4230         else
4231             length = AvMAX(ary) + 1;            /* close enough to infinity */
4232     }
4233     else {
4234         offset = 0;
4235         length = AvMAX(ary) + 1;
4236     }
4237     if (offset > AvFILLp(ary) + 1) {
4238         if (ckWARN(WARN_MISC))
4239             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4240         offset = AvFILLp(ary) + 1;
4241     }
4242     after = AvFILLp(ary) + 1 - (offset + length);
4243     if (after < 0) {                            /* not that much array */
4244         length += after;                        /* offset+length now in array */
4245         after = 0;
4246         if (!AvALLOC(ary))
4247             av_extend(ary, 0);
4248     }
4249
4250     /* At this point, MARK .. SP-1 is our new LIST */
4251
4252     newlen = SP - MARK;
4253     diff = newlen - length;
4254     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4255         av_reify(ary);
4256
4257     /* make new elements SVs now: avoid problems if they're from the array */
4258     for (dst = MARK, i = newlen; i; i--) {
4259         SV * const h = *dst;
4260         *dst++ = newSVsv(h);
4261     }
4262
4263     if (diff < 0) {                             /* shrinking the area */
4264         SV **tmparyval = NULL;
4265         if (newlen) {
4266             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4267             Copy(MARK, tmparyval, newlen, SV*);
4268         }
4269
4270         MARK = ORIGMARK + 1;
4271         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4272             MEXTEND(MARK, length);
4273             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4274             if (AvREAL(ary)) {
4275                 EXTEND_MORTAL(length);
4276                 for (i = length, dst = MARK; i; i--) {
4277                     sv_2mortal(*dst);   /* free them eventualy */
4278                     dst++;
4279                 }
4280             }
4281             MARK += length - 1;
4282         }
4283         else {
4284             *MARK = AvARRAY(ary)[offset+length-1];
4285             if (AvREAL(ary)) {
4286                 sv_2mortal(*MARK);
4287                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4288                     SvREFCNT_dec(*dst++);       /* free them now */
4289             }
4290         }
4291         AvFILLp(ary) += diff;
4292
4293         /* pull up or down? */
4294
4295         if (offset < after) {                   /* easier to pull up */
4296             if (offset) {                       /* esp. if nothing to pull */
4297                 src = &AvARRAY(ary)[offset-1];
4298                 dst = src - diff;               /* diff is negative */
4299                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4300                     *dst-- = *src--;
4301             }
4302             dst = AvARRAY(ary);
4303             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4304             AvMAX(ary) += diff;
4305         }
4306         else {
4307             if (after) {                        /* anything to pull down? */
4308                 src = AvARRAY(ary) + offset + length;
4309                 dst = src + diff;               /* diff is negative */
4310                 Move(src, dst, after, SV*);
4311             }
4312             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4313                                                 /* avoid later double free */
4314         }
4315         i = -diff;
4316         while (i)
4317             dst[--i] = &PL_sv_undef;
4318
4319         if (newlen) {
4320             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4321             Safefree(tmparyval);
4322         }
4323     }
4324     else {                                      /* no, expanding (or same) */
4325         SV** tmparyval = NULL;
4326         if (length) {
4327             Newx(tmparyval, length, SV*);       /* so remember deletion */
4328             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4329         }
4330
4331         if (diff > 0) {                         /* expanding */
4332             /* push up or down? */
4333             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4334                 if (offset) {
4335                     src = AvARRAY(ary);
4336                     dst = src - diff;
4337                     Move(src, dst, offset, SV*);
4338                 }
4339                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4340                 AvMAX(ary) += diff;
4341                 AvFILLp(ary) += diff;
4342             }
4343             else {
4344                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4345                     av_extend(ary, AvFILLp(ary) + diff);
4346                 AvFILLp(ary) += diff;
4347
4348                 if (after) {
4349                     dst = AvARRAY(ary) + AvFILLp(ary);
4350                     src = dst - diff;
4351                     for (i = after; i; i--) {
4352                         *dst-- = *src--;
4353                     }
4354                 }
4355             }
4356         }
4357
4358         if (newlen) {
4359             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4360         }
4361
4362         MARK = ORIGMARK + 1;
4363         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4364             if (length) {
4365                 Copy(tmparyval, MARK, length, SV*);
4366                 if (AvREAL(ary)) {
4367                     EXTEND_MORTAL(length);
4368                     for (i = length, dst = MARK; i; i--) {
4369                         sv_2mortal(*dst);       /* free them eventualy */
4370                         dst++;
4371                     }
4372                 }
4373             }
4374             MARK += length - 1;
4375         }
4376         else if (length--) {
4377             *MARK = tmparyval[length];
4378             if (AvREAL(ary)) {
4379                 sv_2mortal(*MARK);
4380                 while (length-- > 0)
4381                     SvREFCNT_dec(tmparyval[length]);
4382             }
4383         }
4384         else
4385             *MARK = &PL_sv_undef;
4386         Safefree(tmparyval);
4387     }
4388     SP = MARK;
4389     RETURN;
4390 }
4391
4392 PP(pp_push)
4393 {
4394     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4395     register AV * const ary = (AV*)*++MARK;
4396     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4397
4398     if (mg) {
4399         *MARK-- = SvTIED_obj((SV*)ary, mg);
4400         PUSHMARK(MARK);
4401         PUTBACK;
4402         ENTER;
4403         call_method("PUSH",G_SCALAR|G_DISCARD);
4404         LEAVE;
4405         SPAGAIN;
4406         SP = ORIGMARK;
4407         PUSHi( AvFILL(ary) + 1 );
4408     }
4409     else {
4410         for (++MARK; MARK <= SP; MARK++) {
4411             SV * const sv = newSV(0);
4412             if (*MARK)
4413                 sv_setsv(sv, *MARK);
4414             av_store(ary, AvFILLp(ary)+1, sv);
4415         }
4416         SP = ORIGMARK;
4417         PUSHi( AvFILLp(ary) + 1 );
4418     }
4419     RETURN;
4420 }
4421
4422 PP(pp_shift)
4423 {
4424     dVAR;
4425     dSP;
4426     AV * const av = (AV*)POPs;
4427     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4428     EXTEND(SP, 1);
4429     assert (sv);
4430     if (AvREAL(av))
4431         (void)sv_2mortal(sv);
4432     PUSHs(sv);
4433     RETURN;
4434 }
4435
4436 PP(pp_unshift)
4437 {
4438     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4439     register AV *ary = (AV*)*++MARK;
4440     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4441
4442     if (mg) {
4443         *MARK-- = SvTIED_obj((SV*)ary, mg);
4444         PUSHMARK(MARK);
4445         PUTBACK;
4446         ENTER;
4447         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4448         LEAVE;
4449         SPAGAIN;
4450     }
4451     else {
4452         register I32 i = 0;
4453         av_unshift(ary, SP - MARK);
4454         while (MARK < SP) {
4455             SV * const sv = newSVsv(*++MARK);
4456             (void)av_store(ary, i++, sv);
4457         }
4458     }
4459     SP = ORIGMARK;
4460     PUSHi( AvFILL(ary) + 1 );
4461     RETURN;
4462 }
4463
4464 PP(pp_reverse)
4465 {
4466     dVAR; dSP; dMARK;
4467     SV ** const oldsp = SP;
4468
4469     if (GIMME == G_ARRAY) {
4470         MARK++;
4471         while (MARK < SP) {
4472             register SV * const tmp = *MARK;
4473             *MARK++ = *SP;
4474             *SP-- = tmp;
4475         }
4476         /* safe as long as stack cannot get extended in the above */
4477         SP = oldsp;
4478     }
4479     else {
4480         register char *up;
4481         register char *down;
4482         register I32 tmp;
4483         dTARGET;
4484         STRLEN len;
4485         PADOFFSET padoff_du;
4486
4487         SvUTF8_off(TARG);                               /* decontaminate */
4488         if (SP - MARK > 1)
4489             do_join(TARG, &PL_sv_no, MARK, SP);
4490         else
4491             sv_setsv(TARG, (SP > MARK)
4492                     ? *SP
4493                     : (padoff_du = find_rundefsvoffset(),
4494                         (padoff_du == NOT_IN_PAD
4495                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4496                         ? DEFSV : PAD_SVl(padoff_du)));
4497         up = SvPV_force(TARG, len);
4498         if (len > 1) {
4499             if (DO_UTF8(TARG)) {        /* first reverse each character */
4500                 U8* s = (U8*)SvPVX(TARG);
4501                 const U8* send = (U8*)(s + len);
4502                 while (s < send) {
4503                     if (UTF8_IS_INVARIANT(*s)) {
4504                         s++;
4505                         continue;
4506                     }
4507                     else {
4508                         if (!utf8_to_uvchr(s, 0))
4509                             break;
4510                         up = (char*)s;
4511                         s += UTF8SKIP(s);
4512                         down = (char*)(s - 1);
4513                         /* reverse this character */
4514                         while (down > up) {
4515                             tmp = *up;
4516                             *up++ = *down;
4517                             *down-- = (char)tmp;
4518                         }
4519                     }
4520                 }
4521                 up = SvPVX(TARG);
4522             }
4523             down = SvPVX(TARG) + len - 1;
4524             while (down > up) {
4525                 tmp = *up;
4526                 *up++ = *down;
4527                 *down-- = (char)tmp;
4528             }
4529             (void)SvPOK_only_UTF8(TARG);
4530         }
4531         SP = MARK + 1;
4532         SETTARG;
4533     }
4534     RETURN;
4535 }
4536
4537 PP(pp_split)
4538 {
4539     dVAR; dSP; dTARG;
4540     AV *ary;
4541     register IV limit = POPi;                   /* note, negative is forever */
4542     SV * const sv = POPs;
4543     STRLEN len;
4544     register const char *s = SvPV_const(sv, len);
4545     const bool do_utf8 = DO_UTF8(sv);
4546     const char *strend = s + len;
4547     register PMOP *pm;
4548     register REGEXP *rx;
4549     register SV *dstr;
4550     register const char *m;
4551     I32 iters = 0;
4552     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4553     I32 maxiters = slen + 10;
4554     const char *orig;
4555     const I32 origlimit = limit;
4556     I32 realarray = 0;
4557     I32 base;
4558     const I32 gimme = GIMME_V;
4559     const I32 oldsave = PL_savestack_ix;
4560     I32 make_mortal = 1;
4561     bool multiline = 0;
4562     MAGIC *mg = NULL;
4563
4564 #ifdef DEBUGGING
4565     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4566 #else
4567     pm = (PMOP*)POPs;
4568 #endif
4569     if (!pm || !s)
4570         DIE(aTHX_ "panic: pp_split");
4571     rx = PM_GETRE(pm);
4572
4573     TAINT_IF((rx->extflags & RXf_PMf_LOCALE) &&
4574              (rx->extflags & (RXf_WHITE | RXf_SKIPWHITE)));
4575
4576     RX_MATCH_UTF8_set(rx, do_utf8);
4577
4578 #ifdef USE_ITHREADS
4579     if (pm->op_pmreplrootu.op_pmtargetoff) {
4580         ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4581     }
4582 #else
4583     if (pm->op_pmreplrootu.op_pmtargetgv) {
4584         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4585     }
4586 #endif
4587     else if (gimme != G_ARRAY)
4588         ary = GvAVn(PL_defgv);
4589     else
4590         ary = NULL;
4591     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4592         realarray = 1;
4593         PUTBACK;
4594         av_extend(ary,0);
4595         av_clear(ary);
4596         SPAGAIN;
4597         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4598             PUSHMARK(SP);
4599             XPUSHs(SvTIED_obj((SV*)ary, mg));
4600         }
4601         else {
4602             if (!AvREAL(ary)) {
4603                 I32 i;
4604                 AvREAL_on(ary);
4605                 AvREIFY_off(ary);
4606                 for (i = AvFILLp(ary); i >= 0; i--)
4607                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4608             }
4609             /* temporarily switch stacks */
4610             SAVESWITCHSTACK(PL_curstack, ary);
4611             make_mortal = 0;
4612         }
4613     }
4614     base = SP - PL_stack_base;
4615     orig = s;
4616     if (rx->extflags & RXf_SKIPWHITE) {
4617         if (do_utf8) {
4618             while (*s == ' ' || is_utf8_space((U8*)s))
4619                 s += UTF8SKIP(s);
4620         }
4621         else if (rx->extflags & RXf_PMf_LOCALE) {
4622             while (isSPACE_LC(*s))
4623                 s++;
4624         }
4625         else {
4626             while (isSPACE(*s))
4627                 s++;
4628         }
4629     }
4630     if (rx->extflags & PMf_MULTILINE) {
4631         multiline = 1;
4632     }
4633
4634     if (!limit)
4635         limit = maxiters + 2;
4636     if (rx->extflags & RXf_WHITE) {
4637         while (--limit) {
4638             m = s;
4639             /* this one uses 'm' and is a negative test */
4640             if (do_utf8) {
4641                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4642                     const int t = UTF8SKIP(m);
4643                     /* is_utf8_space returns FALSE for malform utf8 */
4644                     if (strend - m < t)
4645                         m = strend;
4646                     else
4647                         m += t;
4648                 }
4649             } else if (rx->extflags & RXf_PMf_LOCALE) {
4650                 while (m < strend && !isSPACE_LC(*m))
4651                     ++m;
4652             } else {
4653                 while (m < strend && !isSPACE(*m))
4654                     ++m;
4655             }
4656             if (m >= strend)
4657                 break;
4658
4659             dstr = newSVpvn(s, m-s);
4660             if (make_mortal)
4661                 sv_2mortal(dstr);
4662             if (do_utf8)
4663                 (void)SvUTF8_on(dstr);
4664             XPUSHs(dstr);
4665
4666             /* skip the whitespace found last */
4667             if (do_utf8)
4668                 s = m + UTF8SKIP(m);
4669             else
4670                 s = m + 1;
4671
4672             /* this one uses 's' and is a positive test */
4673             if (do_utf8) {
4674                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4675                     s +=  UTF8SKIP(s);
4676             } else if (rx->extflags & RXf_PMf_LOCALE) {
4677                 while (s < strend && isSPACE_LC(*s))
4678                     ++s;
4679             } else {
4680                 while (s < strend && isSPACE(*s))
4681                     ++s;
4682             }
4683         }
4684     }
4685     else if (rx->extflags & RXf_START_ONLY) {
4686         while (--limit) {
4687             for (m = s; m < strend && *m != '\n'; m++)
4688                 ;
4689             m++;
4690             if (m >= strend)
4691                 break;
4692             dstr = newSVpvn(s, m-s);
4693             if (make_mortal)
4694                 sv_2mortal(dstr);
4695             if (do_utf8)
4696                 (void)SvUTF8_on(dstr);
4697             XPUSHs(dstr);
4698             s = m;
4699         }
4700     }
4701     else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
4702              (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
4703              && (rx->extflags & RXf_CHECK_ALL)
4704              && !(rx->extflags & RXf_ANCH)) {
4705         const int tail = (rx->extflags & RXf_INTUIT_TAIL);
4706         SV * const csv = CALLREG_INTUIT_STRING(rx);
4707
4708         len = rx->minlenret;
4709         if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
4710             const char c = *SvPV_nolen_const(csv);
4711             while (--limit) {
4712                 for (m = s; m < strend && *m != c; m++)
4713                     ;
4714                 if (m >= strend)
4715                     break;
4716                 dstr = newSVpvn(s, m-s);
4717                 if (make_mortal)
4718                     sv_2mortal(dstr);
4719                 if (do_utf8)
4720                     (void)SvUTF8_on(dstr);
4721                 XPUSHs(dstr);
4722                 /* The rx->minlen is in characters but we want to step
4723                  * s ahead by bytes. */
4724                 if (do_utf8)
4725                     s = (char*)utf8_hop((U8*)m, len);
4726                 else
4727                     s = m + len; /* Fake \n at the end */
4728             }
4729         }
4730         else {
4731             while (s < strend && --limit &&
4732               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4733                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4734             {
4735                 dstr = newSVpvn(s, m-s);
4736                 if (make_mortal)
4737                     sv_2mortal(dstr);
4738                 if (do_utf8)
4739                     (void)SvUTF8_on(dstr);
4740                 XPUSHs(dstr);
4741                 /* The rx->minlen is in characters but we want to step
4742                  * s ahead by bytes. */
4743                 if (do_utf8)
4744                     s = (char*)utf8_hop((U8*)m, len);
4745                 else
4746                     s = m + len; /* Fake \n at the end */
4747             }
4748         }
4749     }
4750     else {
4751         maxiters += slen * rx->nparens;
4752         while (s < strend && --limit)
4753         {
4754             I32 rex_return;
4755             PUTBACK;
4756             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4757                             sv, NULL, 0);
4758             SPAGAIN;
4759             if (rex_return == 0)
4760                 break;
4761             TAINT_IF(RX_MATCH_TAINTED(rx));
4762             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4763                 m = s;
4764                 s = orig;
4765                 orig = rx->subbeg;
4766                 s = orig + (m - s);
4767                 strend = s + (strend - m);
4768             }
4769             m = rx->offs[0].start + orig;
4770             dstr = newSVpvn(s, m-s);
4771             if (make_mortal)
4772                 sv_2mortal(dstr);
4773             if (do_utf8)
4774                 (void)SvUTF8_on(dstr);
4775             XPUSHs(dstr);
4776             if (rx->nparens) {
4777                 I32 i;
4778                 for (i = 1; i <= (I32)rx->nparens; i++) {
4779                     s = rx->offs[i].start + orig;
4780                     m = rx->offs[i].end + orig;
4781
4782                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4783                        parens that didn't match -- they should be set to
4784                        undef, not the empty string */
4785                     if (m >= orig && s >= orig) {
4786                         dstr = newSVpvn(s, m-s);
4787                     }
4788                     else
4789                         dstr = &PL_sv_undef;  /* undef, not "" */
4790                     if (make_mortal)
4791                         sv_2mortal(dstr);
4792                     if (do_utf8)
4793                         (void)SvUTF8_on(dstr);
4794                     XPUSHs(dstr);
4795                 }
4796             }
4797             s = rx->offs[0].end + orig;
4798         }
4799     }
4800
4801     iters = (SP - PL_stack_base) - base;
4802     if (iters > maxiters)
4803         DIE(aTHX_ "Split loop");
4804
4805     /* keep field after final delim? */
4806     if (s < strend || (iters && origlimit)) {
4807         const STRLEN l = strend - s;
4808         dstr = newSVpvn(s, l);
4809         if (make_mortal)
4810             sv_2mortal(dstr);
4811         if (do_utf8)
4812             (void)SvUTF8_on(dstr);
4813         XPUSHs(dstr);
4814         iters++;
4815     }
4816     else if (!origlimit) {
4817         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4818             if (TOPs && !make_mortal)
4819                 sv_2mortal(TOPs);
4820             iters--;
4821             *SP-- = &PL_sv_undef;
4822         }
4823     }
4824
4825     PUTBACK;
4826     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4827     SPAGAIN;
4828     if (realarray) {
4829         if (!mg) {
4830             if (SvSMAGICAL(ary)) {
4831                 PUTBACK;
4832                 mg_set((SV*)ary);
4833                 SPAGAIN;
4834             }
4835             if (gimme == G_ARRAY) {
4836                 EXTEND(SP, iters);
4837                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4838                 SP += iters;
4839                 RETURN;
4840             }
4841         }
4842         else {
4843             PUTBACK;
4844             ENTER;
4845             call_method("PUSH",G_SCALAR|G_DISCARD);
4846             LEAVE;
4847             SPAGAIN;
4848             if (gimme == G_ARRAY) {
4849                 I32 i;
4850                 /* EXTEND should not be needed - we just popped them */
4851                 EXTEND(SP, iters);
4852                 for (i=0; i < iters; i++) {
4853                     SV **svp = av_fetch(ary, i, FALSE);
4854                     PUSHs((svp) ? *svp : &PL_sv_undef);
4855                 }
4856                 RETURN;
4857             }
4858         }
4859     }
4860     else {
4861         if (gimme == G_ARRAY)
4862             RETURN;
4863     }
4864
4865     GETTARGET;
4866     PUSHi(iters);
4867     RETURN;
4868 }
4869
4870 PP(pp_lock)
4871 {
4872     dVAR;
4873     dSP;
4874     dTOPss;
4875     SV *retsv = sv;
4876     SvLOCK(sv);
4877     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4878         || SvTYPE(retsv) == SVt_PVCV) {
4879         retsv = refto(retsv);
4880     }
4881     SETs(retsv);
4882     RETURN;
4883 }
4884
4885
4886 PP(unimplemented_op)
4887 {
4888     dVAR;
4889     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4890         PL_op->op_type);
4891 }
4892
4893 /*
4894  * Local variables:
4895  * c-indentation-style: bsd
4896  * c-basic-offset: 4
4897  * indent-tabs-mode: t
4898  * End:
4899  *
4900  * ex: set ts=8 sts=4 sw=4 noet:
4901  */