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