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