pp.c

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