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