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