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