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