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 = newSVhek(GvNAME_HEK(gv));
 628             break;
 629         case 'P':
 630             if (strEQ(second_letter, "ACKAGE")) {
 631                 const HV * const stash = GvSTASH(gv);
 632                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 633                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 634             }
 635             break;
 636         case 'S':
 637             if (strEQ(second_letter, "CALAR"))
 638                 tmpRef = GvSVn(gv);
 639             break;
 640         }
 641     }
 642     if (tmpRef)
 643         sv = newRV(tmpRef);
 644     if (sv)
 645         sv_2mortal(sv);
 646     else
 647         sv = &PL_sv_undef;
 648     XPUSHs(sv);
 649     RETURN;
 650 }
 651
 652 /* Pattern matching */
 653
 654 PP(pp_study)
 655 {
 656     dVAR; dSP; dPOPss;
 657     register unsigned char *s;
 658     register I32 pos;
 659     register I32 ch;
 660     register I32 *sfirst;
 661     register I32 *snext;
 662     STRLEN len;
 663
 664     if (sv == PL_lastscream) {
 665         if (SvSCREAM(sv))
 666             RETPUSHYES;
 667     }
 668     s = (unsigned char*)(SvPV(sv, len));
 669     pos = len;
 670     if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
 671         /* No point in studying a zero length string, and not safe to study
 672            anything that doesn't appear to be a simple scalar (and hence might
 673            change between now and when the regexp engine runs without our set
 674            magic ever running) such as a reference to an object with overloaded
 675            stringification.  */
 676         RETPUSHNO;
 677     }
 678
 679     if (PL_lastscream) {
 680         SvSCREAM_off(PL_lastscream);
 681         SvREFCNT_dec(PL_lastscream);
 682     }
 683     PL_lastscream = SvREFCNT_inc_simple(sv);
 684
 685     s = (unsigned char*)(SvPV(sv, len));
 686     pos = len;
 687     if (pos <= 0)
 688         RETPUSHNO;
 689     if (pos > PL_maxscream) {
 690         if (PL_maxscream < 0) {
 691             PL_maxscream = pos + 80;
 692             Newx(PL_screamfirst, 256, I32);
 693             Newx(PL_screamnext, PL_maxscream, I32);
 694         }
 695         else {
 696             PL_maxscream = pos + pos / 4;
 697             Renew(PL_screamnext, PL_maxscream, I32);
 698         }
 699     }
 700
 701     sfirst = PL_screamfirst;
 702     snext = PL_screamnext;
 703
 704     if (!sfirst || !snext)
 705         DIE(aTHX_ "do_study: out of memory");
 706
 707     for (ch = 256; ch; --ch)
 708         *sfirst++ = -1;
 709     sfirst -= 256;
 710
 711     while (--pos >= 0) {
 712         register const I32 ch = s[pos];
 713         if (sfirst[ch] >= 0)
 714             snext[pos] = sfirst[ch] - pos;
 715         else
 716             snext[pos] = -pos;
 717         sfirst[ch] = pos;
 718     }
 719
 720     SvSCREAM_on(sv);
 721     /* piggyback on m//g magic */
 722     sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
 723     RETPUSHYES;
 724 }
 725
 726 PP(pp_trans)
 727 {
 728     dVAR; dSP; dTARG;
 729     SV *sv;
 730
 731     if (PL_op->op_flags & OPf_STACKED)
 732         sv = POPs;
 733     else if (PL_op->op_private & OPpTARGET_MY)
 734         sv = GETTARGET;
 735     else {
 736         sv = DEFSV;
 737         EXTEND(SP,1);
 738     }
 739     TARG = sv_newmortal();
 740     PUSHi(do_trans(sv));
 741     RETURN;
 742 }
 743
 744 /* Lvalue operators. */
 745
 746 PP(pp_schop)
 747 {
 748     dVAR; dSP; dTARGET;
 749     do_chop(TARG, TOPs);
 750     SETTARG;
 751     RETURN;
 752 }
 753
 754 PP(pp_chop)
 755 {
 756     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
 757     while (MARK < SP)
 758         do_chop(TARG, *++MARK);
 759     SP = ORIGMARK;
 760     XPUSHTARG;
 761     RETURN;
 762 }
 763
 764 PP(pp_schomp)
 765 {
 766     dVAR; dSP; dTARGET;
 767     SETi(do_chomp(TOPs));
 768     RETURN;
 769 }
 770
 771 PP(pp_chomp)
 772 {
 773     dVAR; dSP; dMARK; dTARGET;
 774     register I32 count = 0;
 775
 776     while (SP > MARK)
 777         count += do_chomp(POPs);
 778     XPUSHi(count);
 779     RETURN;
 780 }
 781
 782 PP(pp_undef)
 783 {
 784     dVAR; dSP;
 785     SV *sv;
 786
 787     if (!PL_op->op_private) {
 788         EXTEND(SP, 1);
 789         RETPUSHUNDEF;
 790     }
 791
 792     sv = POPs;
 793     if (!sv)
 794         RETPUSHUNDEF;
 795
 796     SV_CHECK_THINKFIRST_COW_DROP(sv);
 797
 798     switch (SvTYPE(sv)) {
 799     case SVt_NULL:
 800         break;
 801     case SVt_PVAV:
 802         av_undef((AV*)sv);
 803         break;
 804     case SVt_PVHV:
 805         hv_undef((HV*)sv);
 806         break;
 807     case SVt_PVCV:
 808         if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
 809             Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
 810                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
 811         /* FALLTHROUGH */
 812     case SVt_PVFM:
 813         {
 814             /* let user-undef'd sub keep its identity */
 815             GV* const gv = CvGV((CV*)sv);
 816             cv_undef((CV*)sv);
 817             CvGV((CV*)sv) = gv;
 818         }
 819         break;
 820     case SVt_PVGV:
 821         if (SvFAKE(sv))
 822             SvSetMagicSV(sv, &PL_sv_undef);
 823         else {
 824             GP *gp;
 825             HV *stash;
 826
 827             /* undef *Foo:: */
 828             if((stash = GvHV((GV*)sv)) && HvNAME_get(stash))
 829                 mro_isa_changed_in(stash);
 830             /* undef *Pkg::meth_name ... */
 831             else if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
 832                 mro_method_changed_in(stash);
 833
 834             gp_free((GV*)sv);
 835             Newxz(gp, 1, GP);
 836             GvGP(sv) = gp_ref(gp);
 837             GvSV(sv) = newSV(0);
 838             GvLINE(sv) = CopLINE(PL_curcop);
 839             GvEGV(sv) = (GV*)sv;
 840             GvMULTI_on(sv);
 841         }
 842         break;
 843     default:
 844         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 845             SvPV_free(sv);
 846             SvPV_set(sv, NULL);
 847             SvLEN_set(sv, 0);
 848         }
 849         SvOK_off(sv);
 850         SvSETMAGIC(sv);
 851     }
 852
 853     RETPUSHUNDEF;
 854 }
 855
 856 PP(pp_predec)
 857 {
 858     dVAR; dSP;
 859     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 860         DIE(aTHX_ PL_no_modify);
 861     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 862         && SvIVX(TOPs) != IV_MIN)
 863     {
 864         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 865         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 866     }
 867     else
 868         sv_dec(TOPs);
 869     SvSETMAGIC(TOPs);
 870     return NORMAL;
 871 }
 872
 873 PP(pp_postinc)
 874 {
 875     dVAR; dSP; dTARGET;
 876     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 877         DIE(aTHX_ PL_no_modify);
 878     sv_setsv(TARG, TOPs);
 879     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 880         && SvIVX(TOPs) != IV_MAX)
 881     {
 882         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 883         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 884     }
 885     else
 886         sv_inc(TOPs);
 887     SvSETMAGIC(TOPs);
 888     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
 889     if (!SvOK(TARG))
 890         sv_setiv(TARG, 0);
 891     SETs(TARG);
 892     return NORMAL;
 893 }
 894
 895 PP(pp_postdec)
 896 {
 897     dVAR; dSP; dTARGET;
 898     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 899         DIE(aTHX_ PL_no_modify);
 900     sv_setsv(TARG, TOPs);
 901     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 902         && SvIVX(TOPs) != IV_MIN)
 903     {
 904         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 905         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 906     }
 907     else
 908         sv_dec(TOPs);
 909     SvSETMAGIC(TOPs);
 910     SETs(TARG);
 911     return NORMAL;
 912 }
 913
 914 /* Ordinary operators. */
 915
 916 PP(pp_pow)
 917 {
 918     dVAR; dSP; dATARGET; SV *svl, *svr;
 919 #ifdef PERL_PRESERVE_IVUV
 920     bool is_int = 0;
 921 #endif
 922     tryAMAGICbin(pow,opASSIGN);
 923     svl = sv_2num(TOPm1s);
 924     svr = sv_2num(TOPs);
 925 #ifdef PERL_PRESERVE_IVUV
 926     /* For integer to integer power, we do the calculation by hand wherever
 927        we're sure it is safe; otherwise we call pow() and try to convert to
 928        integer afterwards. */
 929     {
 930         SvIV_please(svr);
 931         if (SvIOK(svr)) {
 932             SvIV_please(svl);
 933             if (SvIOK(svl)) {
 934                 UV power;
 935                 bool baseuok;
 936                 UV baseuv;
 937
 938                 if (SvUOK(svr)) {
 939                     power = SvUVX(svr);
 940                 } else {
 941                     const IV iv = SvIVX(svr);
 942                     if (iv >= 0) {
 943                         power = iv;
 944                     } else {
 945                         goto float_it; /* Can't do negative powers this way.  */
 946                     }
 947                 }
 948
 949                 baseuok = SvUOK(svl);
 950                 if (baseuok) {
 951                     baseuv = SvUVX(svl);
 952                 } else {
 953                     const IV iv = SvIVX(svl);
 954                     if (iv >= 0) {
 955                         baseuv = iv;
 956                         baseuok = TRUE; /* effectively it's a UV now */
 957                     } else {
 958                         baseuv = -iv; /* abs, baseuok == false records sign */
 959                     }
 960                 }
 961                 /* now we have integer ** positive integer. */
 962                 is_int = 1;
 963
 964                 /* foo & (foo - 1) is zero only for a power of 2.  */
 965                 if (!(baseuv & (baseuv - 1))) {
 966                     /* We are raising power-of-2 to a positive integer.
 967                        The logic here will work for any base (even non-integer
 968                        bases) but it can be less accurate than
 969                        pow (base,power) or exp (power * log (base)) when the
 970                        intermediate values start to spill out of the mantissa.
 971                        With powers of 2 we know this can't happen.
 972                        And powers of 2 are the favourite thing for perl
 973                        programmers to notice ** not doing what they mean. */
 974                     NV result = 1.0;
 975                     NV base = baseuok ? baseuv : -(NV)baseuv;
 976
 977                     if (power & 1) {
 978                         result *= base;
 979                     }
 980                     while (power >>= 1) {
 981                         base *= base;
 982                         if (power & 1) {
 983                             result *= base;
 984                         }
 985                     }
 986                     SP--;
 987                     SETn( result );
 988                     SvIV_please(svr);
 989                     RETURN;
 990                 } else {
 991                     register unsigned int highbit = 8 * sizeof(UV);
 992                     register unsigned int diff = 8 * sizeof(UV);
 993                     while (diff >>= 1) {
 994                         highbit -= diff;
 995                         if (baseuv >> highbit) {
 996                             highbit += diff;
 997                         }
 998                     }
 999                     /* we now have baseuv < 2 ** highbit */
1000                     if (power * highbit <= 8 * sizeof(UV)) {
1001                         /* result will definitely fit in UV, so use UV math
1002                            on same algorithm as above */
1003                         register UV result = 1;
1004                         register UV base = baseuv;
1005                         const bool odd_power = (bool)(power & 1);
1006                         if (odd_power) {
1007                             result *= base;
1008                         }
1009                         while (power >>= 1) {
1010                             base *= base;
1011                             if (power & 1) {
1012                                 result *= base;
1013                             }
1014                         }
1015                         SP--;
1016                         if (baseuok || !odd_power)
1017                             /* answer is positive */
1018                             SETu( result );
1019                         else if (result <= (UV)IV_MAX)
1020                             /* answer negative, fits in IV */
1021                             SETi( -(IV)result );
1022                         else if (result == (UV)IV_MIN)
1023                             /* 2's complement assumption: special case IV_MIN */
1024                             SETi( IV_MIN );
1025                         else
1026                             /* answer negative, doesn't fit */
1027                             SETn( -(NV)result );
1028                         RETURN;
1029                     }
1030                 }
1031             }
1032         }
1033     }
1034   float_it:
1035 #endif
1036     {
1037         NV right = SvNV(svr);
1038         NV left  = SvNV(svl);
1039         (void)POPs;
1040
1041 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1042     /*
1043     We are building perl with long double support and are on an AIX OS
1044     afflicted with a powl() function that wrongly returns NaNQ for any
1045     negative base.  This was reported to IBM as PMR #23047-379 on
1046     03/06/2006.  The problem exists in at least the following versions
1047     of AIX and the libm fileset, and no doubt others as well:
1048
1049         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1050         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1051         AIX 5.2.0           bos.adt.libm 5.2.0.85
1052
1053     So, until IBM fixes powl(), we provide the following workaround to
1054     handle the problem ourselves.  Our logic is as follows: for
1055     negative bases (left), we use fmod(right, 2) to check if the
1056     exponent is an odd or even integer:
1057
1058         - if odd,  powl(left, right) == -powl(-left, right)
1059         - if even, powl(left, right) ==  powl(-left, right)
1060
1061     If the exponent is not an integer, the result is rightly NaNQ, so
1062     we just return that (as NV_NAN).
1063     */
1064
1065         if (left < 0.0) {
1066             NV mod2 = Perl_fmod( right, 2.0 );
1067             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1068                 SETn( -Perl_pow( -left, right) );
1069             } else if (mod2 == 0.0) {           /* even integer */
1070                 SETn( Perl_pow( -left, right) );
1071             } else {                            /* fractional power */
1072                 SETn( NV_NAN );
1073             }
1074         } else {
1075             SETn( Perl_pow( left, right) );
1076         }
1077 #else
1078         SETn( Perl_pow( left, right) );
1079 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1080
1081 #ifdef PERL_PRESERVE_IVUV
1082         if (is_int)
1083             SvIV_please(svr);
1084 #endif
1085         RETURN;
1086     }
1087 }
1088
1089 PP(pp_multiply)
1090 {
1091     dVAR; dSP; dATARGET; SV *svl, *svr;
1092     tryAMAGICbin(mult,opASSIGN);
1093     svl = sv_2num(TOPm1s);
1094     svr = sv_2num(TOPs);
1095 #ifdef PERL_PRESERVE_IVUV
1096     SvIV_please(svr);
1097     if (SvIOK(svr)) {
1098         /* Unless the left argument is integer in range we are going to have to
1099            use NV maths. Hence only attempt to coerce the right argument if
1100            we know the left is integer.  */
1101         /* Left operand is defined, so is it IV? */
1102         SvIV_please(svl);
1103         if (SvIOK(svl)) {
1104             bool auvok = SvUOK(svl);
1105             bool buvok = SvUOK(svr);
1106             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1107             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1108             UV alow;
1109             UV ahigh;
1110             UV blow;
1111             UV bhigh;
1112
1113             if (auvok) {
1114                 alow = SvUVX(svl);
1115             } else {
1116                 const IV aiv = SvIVX(svl);
1117                 if (aiv >= 0) {
1118                     alow = aiv;
1119                     auvok = TRUE; /* effectively it's a UV now */
1120                 } else {
1121                     alow = -aiv; /* abs, auvok == false records sign */
1122                 }
1123             }
1124             if (buvok) {
1125                 blow = SvUVX(svr);
1126             } else {
1127                 const IV biv = SvIVX(svr);
1128                 if (biv >= 0) {
1129                     blow = biv;
1130                     buvok = TRUE; /* effectively it's a UV now */
1131                 } else {
1132                     blow = -biv; /* abs, buvok == false records sign */
1133                 }
1134             }
1135
1136             /* If this does sign extension on unsigned it's time for plan B  */
1137             ahigh = alow >> (4 * sizeof (UV));
1138             alow &= botmask;
1139             bhigh = blow >> (4 * sizeof (UV));
1140             blow &= botmask;
1141             if (ahigh && bhigh) {
1142                 NOOP;
1143                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1144                    which is overflow. Drop to NVs below.  */
1145             } else if (!ahigh && !bhigh) {
1146                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1147                    so the unsigned multiply cannot overflow.  */
1148                 const UV product = alow * blow;
1149                 if (auvok == buvok) {
1150                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1151                     SP--;
1152                     SETu( product );
1153                     RETURN;
1154                 } else if (product <= (UV)IV_MIN) {
1155                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1156                     /* -ve result, which could overflow an IV  */
1157                     SP--;
1158                     SETi( -(IV)product );
1159                     RETURN;
1160                 } /* else drop to NVs below. */
1161             } else {
1162                 /* One operand is large, 1 small */
1163                 UV product_middle;
1164                 if (bhigh) {
1165                     /* swap the operands */
1166                     ahigh = bhigh;
1167                     bhigh = blow; /* bhigh now the temp var for the swap */
1168                     blow = alow;
1169                     alow = bhigh;
1170                 }
1171                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1172                    multiplies can't overflow. shift can, add can, -ve can.  */
1173                 product_middle = ahigh * blow;
1174                 if (!(product_middle & topmask)) {
1175                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1176                     UV product_low;
1177                     product_middle <<= (4 * sizeof (UV));
1178                     product_low = alow * blow;
1179
1180                     /* as for pp_add, UV + something mustn't get smaller.
1181                        IIRC ANSI mandates this wrapping *behaviour* for
1182                        unsigned whatever the actual representation*/
1183                     product_low += product_middle;
1184                     if (product_low >= product_middle) {
1185                         /* didn't overflow */
1186                         if (auvok == buvok) {
1187                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1188                             SP--;
1189                             SETu( product_low );
1190                             RETURN;
1191                         } else if (product_low <= (UV)IV_MIN) {
1192                             /* 2s complement assumption again  */
1193                             /* -ve result, which could overflow an IV  */
1194                             SP--;
1195                             SETi( -(IV)product_low );
1196                             RETURN;
1197                         } /* else drop to NVs below. */
1198                     }
1199                 } /* product_middle too large */
1200             } /* ahigh && bhigh */
1201         } /* SvIOK(svl) */
1202     } /* SvIOK(svr) */
1203 #endif
1204     {
1205       NV right = SvNV(svr);
1206       NV left  = SvNV(svl);
1207       (void)POPs;
1208       SETn( left * right );
1209       RETURN;
1210     }
1211 }
1212
1213 PP(pp_divide)
1214 {
1215     dVAR; dSP; dATARGET; SV *svl, *svr;
1216     tryAMAGICbin(div,opASSIGN);
1217     svl = sv_2num(TOPm1s);
1218     svr = sv_2num(TOPs);
1219     /* Only try to do UV divide first
1220        if ((SLOPPYDIVIDE is true) or
1221            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1222             to preserve))
1223        The assumption is that it is better to use floating point divide
1224        whenever possible, only doing integer divide first if we can't be sure.
1225        If NV_PRESERVES_UV is true then we know at compile time that no UV
1226        can be too large to preserve, so don't need to compile the code to
1227        test the size of UVs.  */
1228
1229 #ifdef SLOPPYDIVIDE
1230 #  define PERL_TRY_UV_DIVIDE
1231     /* ensure that 20./5. == 4. */
1232 #else
1233 #  ifdef PERL_PRESERVE_IVUV
1234 #    ifndef NV_PRESERVES_UV
1235 #      define PERL_TRY_UV_DIVIDE
1236 #    endif
1237 #  endif
1238 #endif
1239
1240 #ifdef PERL_TRY_UV_DIVIDE
1241     SvIV_please(svr);
1242     if (SvIOK(svr)) {
1243         SvIV_please(svl);
1244         if (SvIOK(svl)) {
1245             bool left_non_neg = SvUOK(svl);
1246             bool right_non_neg = SvUOK(svr);
1247             UV left;
1248             UV right;
1249
1250             if (right_non_neg) {
1251                 right = SvUVX(svr);
1252             }
1253             else {
1254                 const IV biv = SvIVX(svr);
1255                 if (biv >= 0) {
1256                     right = biv;
1257                     right_non_neg = TRUE; /* effectively it's a UV now */
1258                 }
1259                 else {
1260                     right = -biv;
1261                 }
1262             }
1263             /* historically undef()/0 gives a "Use of uninitialized value"
1264                warning before dieing, hence this test goes here.
1265                If it were immediately before the second SvIV_please, then
1266                DIE() would be invoked before left was even inspected, so
1267                no inpsection would give no warning.  */
1268             if (right == 0)
1269                 DIE(aTHX_ "Illegal division by zero");
1270
1271             if (left_non_neg) {
1272                 left = SvUVX(svl);
1273             }
1274             else {
1275                 const IV aiv = SvIVX(svl);
1276                 if (aiv >= 0) {
1277                     left = aiv;
1278                     left_non_neg = TRUE; /* effectively it's a UV now */
1279                 }
1280                 else {
1281                     left = -aiv;
1282                 }
1283             }
1284
1285             if (left >= right
1286 #ifdef SLOPPYDIVIDE
1287                 /* For sloppy divide we always attempt integer division.  */
1288 #else
1289                 /* Otherwise we only attempt it if either or both operands
1290                    would not be preserved by an NV.  If both fit in NVs
1291                    we fall through to the NV divide code below.  However,
1292                    as left >= right to ensure integer result here, we know that
1293                    we can skip the test on the right operand - right big
1294                    enough not to be preserved can't get here unless left is
1295                    also too big.  */
1296
1297                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1298 #endif
1299                 ) {
1300                 /* Integer division can't overflow, but it can be imprecise.  */
1301                 const UV result = left / right;
1302                 if (result * right == left) {
1303                     SP--; /* result is valid */
1304                     if (left_non_neg == right_non_neg) {
1305                         /* signs identical, result is positive.  */
1306                         SETu( result );
1307                         RETURN;
1308                     }
1309                     /* 2s complement assumption */
1310                     if (result <= (UV)IV_MIN)
1311                         SETi( -(IV)result );
1312                     else {
1313                         /* It's exact but too negative for IV. */
1314                         SETn( -(NV)result );
1315                     }
1316                     RETURN;
1317                 } /* tried integer divide but it was not an integer result */
1318             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1319         } /* left wasn't SvIOK */
1320     } /* right wasn't SvIOK */
1321 #endif /* PERL_TRY_UV_DIVIDE */
1322     {
1323         NV right = SvNV(svr);
1324         NV left  = SvNV(svl);
1325         (void)POPs;(void)POPs;
1326 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1327         if (! Perl_isnan(right) && right == 0.0)
1328 #else
1329         if (right == 0.0)
1330 #endif
1331             DIE(aTHX_ "Illegal division by zero");
1332         PUSHn( left / right );
1333         RETURN;
1334     }
1335 }
1336
1337 PP(pp_modulo)
1338 {
1339     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1340     {
1341         UV left  = 0;
1342         UV right = 0;
1343         bool left_neg = FALSE;
1344         bool right_neg = FALSE;
1345         bool use_double = FALSE;
1346         bool dright_valid = FALSE;
1347         NV dright = 0.0;
1348         NV dleft  = 0.0;
1349         SV * svl;
1350         SV * const svr = sv_2num(TOPs);
1351         SvIV_please(svr);
1352         if (SvIOK(svr)) {
1353             right_neg = !SvUOK(svr);
1354             if (!right_neg) {
1355                 right = SvUVX(svr);
1356             } else {
1357                 const IV biv = SvIVX(svr);
1358                 if (biv >= 0) {
1359                     right = biv;
1360                     right_neg = FALSE; /* effectively it's a UV now */
1361                 } else {
1362                     right = -biv;
1363                 }
1364             }
1365         }
1366         else {
1367             dright = SvNV(svr);
1368             right_neg = dright < 0;
1369             if (right_neg)
1370                 dright = -dright;
1371             if (dright < UV_MAX_P1) {
1372                 right = U_V(dright);
1373                 dright_valid = TRUE; /* In case we need to use double below.  */
1374             } else {
1375                 use_double = TRUE;
1376             }
1377         }
1378         sp--;
1379
1380         /* At this point use_double is only true if right is out of range for
1381            a UV.  In range NV has been rounded down to nearest UV and
1382            use_double false.  */
1383         svl = sv_2num(TOPs);
1384         SvIV_please(svl);
1385         if (!use_double && SvIOK(svl)) {
1386             if (SvIOK(svl)) {
1387                 left_neg = !SvUOK(svl);
1388                 if (!left_neg) {
1389                     left = SvUVX(svl);
1390                 } else {
1391                     const IV aiv = SvIVX(svl);
1392                     if (aiv >= 0) {
1393                         left = aiv;
1394                         left_neg = FALSE; /* effectively it's a UV now */
1395                     } else {
1396                         left = -aiv;
1397                     }
1398                 }
1399             }
1400         }
1401         else {
1402             dleft = SvNV(svl);
1403             left_neg = dleft < 0;
1404             if (left_neg)
1405                 dleft = -dleft;
1406
1407             /* This should be exactly the 5.6 behaviour - if left and right are
1408                both in range for UV then use U_V() rather than floor.  */
1409             if (!use_double) {
1410                 if (dleft < UV_MAX_P1) {
1411                     /* right was in range, so is dleft, so use UVs not double.
1412                      */
1413                     left = U_V(dleft);
1414                 }
1415                 /* left is out of range for UV, right was in range, so promote
1416                    right (back) to double.  */
1417                 else {
1418                     /* The +0.5 is used in 5.6 even though it is not strictly
1419                        consistent with the implicit +0 floor in the U_V()
1420                        inside the #if 1. */
1421                     dleft = Perl_floor(dleft + 0.5);
1422                     use_double = TRUE;
1423                     if (dright_valid)
1424                         dright = Perl_floor(dright + 0.5);
1425                     else
1426                         dright = right;
1427                 }
1428             }
1429         }
1430         sp--;
1431         if (use_double) {
1432             NV dans;
1433
1434             if (!dright)
1435                 DIE(aTHX_ "Illegal modulus zero");
1436
1437             dans = Perl_fmod(dleft, dright);
1438             if ((left_neg != right_neg) && dans)
1439                 dans = dright - dans;
1440             if (right_neg)
1441                 dans = -dans;
1442             sv_setnv(TARG, dans);
1443         }
1444         else {
1445             UV ans;
1446
1447             if (!right)
1448                 DIE(aTHX_ "Illegal modulus zero");
1449
1450             ans = left % right;
1451             if ((left_neg != right_neg) && ans)
1452                 ans = right - ans;
1453             if (right_neg) {
1454                 /* XXX may warn: unary minus operator applied to unsigned type */
1455                 /* could change -foo to be (~foo)+1 instead     */
1456                 if (ans <= ~((UV)IV_MAX)+1)
1457                     sv_setiv(TARG, ~ans+1);
1458                 else
1459                     sv_setnv(TARG, -(NV)ans);
1460             }
1461             else
1462                 sv_setuv(TARG, ans);
1463         }
1464         PUSHTARG;
1465         RETURN;
1466     }
1467 }
1468
1469 PP(pp_repeat)
1470 {
1471   dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1472   {
1473     register IV count;
1474     dPOPss;
1475     SvGETMAGIC(sv);
1476     if (SvIOKp(sv)) {
1477          if (SvUOK(sv)) {
1478               const UV uv = SvUV(sv);
1479               if (uv > IV_MAX)
1480                    count = IV_MAX; /* The best we can do? */
1481               else
1482                    count = uv;
1483          } else {
1484               const IV iv = SvIV(sv);
1485               if (iv < 0)
1486                    count = 0;
1487               else
1488                    count = iv;
1489          }
1490     }
1491     else if (SvNOKp(sv)) {
1492          const NV nv = SvNV(sv);
1493          if (nv < 0.0)
1494               count = 0;
1495          else
1496               count = (IV)nv;
1497     }
1498     else
1499          count = SvIV(sv);
1500     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1501         dMARK;
1502         static const char oom_list_extend[] = "Out of memory during list extend";
1503         const I32 items = SP - MARK;
1504         const I32 max = items * count;
1505
1506         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1507         /* Did the max computation overflow? */
1508         if (items > 0 && max > 0 && (max < items || max < count))
1509            Perl_croak(aTHX_ oom_list_extend);
1510         MEXTEND(MARK, max);
1511         if (count > 1) {
1512             while (SP > MARK) {
1513 #if 0
1514               /* This code was intended to fix 20010809.028:
1515
1516                  $x = 'abcd';
1517                  for (($x =~ /./g) x 2) {
1518                      print chop; # "abcdabcd" expected as output.
1519                  }
1520
1521                * but that change (#11635) broke this code:
1522
1523                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1524
1525                * I can't think of a better fix that doesn't introduce
1526                * an efficiency hit by copying the SVs. The stack isn't
1527                * refcounted, and mortalisation obviously doesn't
1528                * Do The Right Thing when the stack has more than
1529                * one pointer to the same mortal value.
1530                * .robin.
1531                */
1532                 if (*SP) {
1533                     *SP = sv_2mortal(newSVsv(*SP));
1534                     SvREADONLY_on(*SP);
1535                 }
1536 #else
1537                if (*SP)
1538                    SvTEMP_off((*SP));
1539 #endif
1540                 SP--;
1541             }
1542             MARK++;
1543             repeatcpy((char*)(MARK + items), (char*)MARK,
1544                 items * sizeof(SV*), count - 1);
1545             SP += max;
1546         }
1547         else if (count <= 0)
1548             SP -= items;
1549     }
1550     else {      /* Note: mark already snarfed by pp_list */
1551         SV * const tmpstr = POPs;
1552         STRLEN len;
1553         bool isutf;
1554         static const char oom_string_extend[] =
1555           "Out of memory during string extend";
1556
1557         SvSetSV(TARG, tmpstr);
1558         SvPV_force(TARG, len);
1559         isutf = DO_UTF8(TARG);
1560         if (count != 1) {
1561             if (count < 1)
1562                 SvCUR_set(TARG, 0);
1563             else {
1564                 const STRLEN max = (UV)count * len;
1565                 if (len > MEM_SIZE_MAX / count)
1566                      Perl_croak(aTHX_ oom_string_extend);
1567                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1568                 SvGROW(TARG, max + 1);
1569                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1570                 SvCUR_set(TARG, SvCUR(TARG) * count);
1571             }
1572             *SvEND(TARG) = '\0';
1573         }
1574         if (isutf)
1575             (void)SvPOK_only_UTF8(TARG);
1576         else
1577             (void)SvPOK_only(TARG);
1578
1579         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1580             /* The parser saw this as a list repeat, and there
1581                are probably several items on the stack. But we're
1582                in scalar context, and there's no pp_list to save us
1583                now. So drop the rest of the items -- robin@kitsite.com
1584              */
1585             dMARK;
1586             SP = MARK;
1587         }
1588         PUSHTARG;
1589     }
1590     RETURN;
1591   }
1592 }
1593
1594 PP(pp_subtract)
1595 {
1596     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1597     tryAMAGICbin(subtr,opASSIGN);
1598     svl = sv_2num(TOPm1s);
1599     svr = sv_2num(TOPs);
1600     useleft = USE_LEFT(svl);
1601 #ifdef PERL_PRESERVE_IVUV
1602     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1603        "bad things" happen if you rely on signed integers wrapping.  */
1604     SvIV_please(svr);
1605     if (SvIOK(svr)) {
1606         /* Unless the left argument is integer in range we are going to have to
1607            use NV maths. Hence only attempt to coerce the right argument if
1608            we know the left is integer.  */
1609         register UV auv = 0;
1610         bool auvok = FALSE;
1611         bool a_valid = 0;
1612
1613         if (!useleft) {
1614             auv = 0;
1615             a_valid = auvok = 1;
1616             /* left operand is undef, treat as zero.  */
1617         } else {
1618             /* Left operand is defined, so is it IV? */
1619             SvIV_please(svl);
1620             if (SvIOK(svl)) {
1621                 if ((auvok = SvUOK(svl)))
1622                     auv = SvUVX(svl);
1623                 else {
1624                     register const IV aiv = SvIVX(svl);
1625                     if (aiv >= 0) {
1626                         auv = aiv;
1627                         auvok = 1;      /* Now acting as a sign flag.  */
1628                     } else { /* 2s complement assumption for IV_MIN */
1629                         auv = (UV)-aiv;
1630                     }
1631                 }
1632                 a_valid = 1;
1633             }
1634         }
1635         if (a_valid) {
1636             bool result_good = 0;
1637             UV result;
1638             register UV buv;
1639             bool buvok = SvUOK(svr);
1640
1641             if (buvok)
1642                 buv = SvUVX(svr);
1643             else {
1644                 register const IV biv = SvIVX(svr);
1645                 if (biv >= 0) {
1646                     buv = biv;
1647                     buvok = 1;
1648                 } else
1649                     buv = (UV)-biv;
1650             }
1651             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1652                else "IV" now, independent of how it came in.
1653                if a, b represents positive, A, B negative, a maps to -A etc
1654                a - b =>  (a - b)
1655                A - b => -(a + b)
1656                a - B =>  (a + b)
1657                A - B => -(a - b)
1658                all UV maths. negate result if A negative.
1659                subtract if signs same, add if signs differ. */
1660
1661             if (auvok ^ buvok) {
1662                 /* Signs differ.  */
1663                 result = auv + buv;
1664                 if (result >= auv)
1665                     result_good = 1;
1666             } else {
1667                 /* Signs same */
1668                 if (auv >= buv) {
1669                     result = auv - buv;
1670                     /* Must get smaller */
1671                     if (result <= auv)
1672                         result_good = 1;
1673                 } else {
1674                     result = buv - auv;
1675                     if (result <= buv) {
1676                         /* result really should be -(auv-buv). as its negation
1677                            of true value, need to swap our result flag  */
1678                         auvok = !auvok;
1679                         result_good = 1;
1680                     }
1681                 }
1682             }
1683             if (result_good) {
1684                 SP--;
1685                 if (auvok)
1686                     SETu( result );
1687                 else {
1688                     /* Negate result */
1689                     if (result <= (UV)IV_MIN)
1690                         SETi( -(IV)result );
1691                     else {
1692                         /* result valid, but out of range for IV.  */
1693                         SETn( -(NV)result );
1694                     }
1695                 }
1696                 RETURN;
1697             } /* Overflow, drop through to NVs.  */
1698         }
1699     }
1700 #endif
1701     {
1702         NV value = SvNV(svr);
1703         (void)POPs;
1704
1705         if (!useleft) {
1706             /* left operand is undef, treat as zero - value */
1707             SETn(-value);
1708             RETURN;
1709         }
1710         SETn( SvNV(svl) - value );
1711         RETURN;
1712     }
1713 }
1714
1715 PP(pp_left_shift)
1716 {
1717     dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1718     {
1719       const IV shift = POPi;
1720       if (PL_op->op_private & HINT_INTEGER) {
1721         const IV i = TOPi;
1722         SETi(i << shift);
1723       }
1724       else {
1725         const UV u = TOPu;
1726         SETu(u << shift);
1727       }
1728       RETURN;
1729     }
1730 }
1731
1732 PP(pp_right_shift)
1733 {
1734     dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1735     {
1736       const IV shift = POPi;
1737       if (PL_op->op_private & HINT_INTEGER) {
1738         const IV i = TOPi;
1739         SETi(i >> shift);
1740       }
1741       else {
1742         const UV u = TOPu;
1743         SETu(u >> shift);
1744       }
1745       RETURN;
1746     }
1747 }
1748
1749 PP(pp_lt)
1750 {
1751     dVAR; dSP; tryAMAGICbinSET(lt,0);
1752 #ifdef PERL_PRESERVE_IVUV
1753     SvIV_please(TOPs);
1754     if (SvIOK(TOPs)) {
1755         SvIV_please(TOPm1s);
1756         if (SvIOK(TOPm1s)) {
1757             bool auvok = SvUOK(TOPm1s);
1758             bool buvok = SvUOK(TOPs);
1759
1760             if (!auvok && !buvok) { /* ## IV < IV ## */
1761                 const IV aiv = SvIVX(TOPm1s);
1762                 const IV biv = SvIVX(TOPs);
1763
1764                 SP--;
1765                 SETs(boolSV(aiv < biv));
1766                 RETURN;
1767             }
1768             if (auvok && buvok) { /* ## UV < UV ## */
1769                 const UV auv = SvUVX(TOPm1s);
1770                 const UV buv = SvUVX(TOPs);
1771
1772                 SP--;
1773                 SETs(boolSV(auv < buv));
1774                 RETURN;
1775             }
1776             if (auvok) { /* ## UV < IV ## */
1777                 UV auv;
1778                 const IV biv = SvIVX(TOPs);
1779                 SP--;
1780                 if (biv < 0) {
1781                     /* As (a) is a UV, it's >=0, so it cannot be < */
1782                     SETs(&PL_sv_no);
1783                     RETURN;
1784                 }
1785                 auv = SvUVX(TOPs);
1786                 SETs(boolSV(auv < (UV)biv));
1787                 RETURN;
1788             }
1789             { /* ## IV < UV ## */
1790                 const IV aiv = SvIVX(TOPm1s);
1791                 UV buv;
1792
1793                 if (aiv < 0) {
1794                     /* As (b) is a UV, it's >=0, so it must be < */
1795                     SP--;
1796                     SETs(&PL_sv_yes);
1797                     RETURN;
1798                 }
1799                 buv = SvUVX(TOPs);
1800                 SP--;
1801                 SETs(boolSV((UV)aiv < buv));
1802                 RETURN;
1803             }
1804         }
1805     }
1806 #endif
1807 #ifndef NV_PRESERVES_UV
1808 #ifdef PERL_PRESERVE_IVUV
1809     else
1810 #endif
1811     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1812         SP--;
1813         SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1814         RETURN;
1815     }
1816 #endif
1817     {
1818 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1819       dPOPTOPnnrl;
1820       if (Perl_isnan(left) || Perl_isnan(right))
1821           RETSETNO;
1822       SETs(boolSV(left < right));
1823 #else
1824       dPOPnv;
1825       SETs(boolSV(TOPn < value));
1826 #endif
1827       RETURN;
1828     }
1829 }
1830
1831 PP(pp_gt)
1832 {
1833     dVAR; dSP; tryAMAGICbinSET(gt,0);
1834 #ifdef PERL_PRESERVE_IVUV
1835     SvIV_please(TOPs);
1836     if (SvIOK(TOPs)) {
1837         SvIV_please(TOPm1s);
1838         if (SvIOK(TOPm1s)) {
1839             bool auvok = SvUOK(TOPm1s);
1840             bool buvok = SvUOK(TOPs);
1841
1842             if (!auvok && !buvok) { /* ## IV > IV ## */
1843                 const IV aiv = SvIVX(TOPm1s);
1844                 const IV biv = SvIVX(TOPs);
1845
1846                 SP--;
1847                 SETs(boolSV(aiv > biv));
1848                 RETURN;
1849             }
1850             if (auvok && buvok) { /* ## UV > UV ## */
1851                 const UV auv = SvUVX(TOPm1s);
1852                 const UV buv = SvUVX(TOPs);
1853
1854                 SP--;
1855                 SETs(boolSV(auv > buv));
1856                 RETURN;
1857             }
1858             if (auvok) { /* ## UV > IV ## */
1859                 UV auv;
1860                 const IV biv = SvIVX(TOPs);
1861
1862                 SP--;
1863                 if (biv < 0) {
1864                     /* As (a) is a UV, it's >=0, so it must be > */
1865                     SETs(&PL_sv_yes);
1866                     RETURN;
1867                 }
1868                 auv = SvUVX(TOPs);
1869                 SETs(boolSV(auv > (UV)biv));
1870                 RETURN;
1871             }
1872             { /* ## IV > UV ## */
1873                 const IV aiv = SvIVX(TOPm1s);
1874                 UV buv;
1875
1876                 if (aiv < 0) {
1877                     /* As (b) is a UV, it's >=0, so it cannot be > */
1878                     SP--;
1879                     SETs(&PL_sv_no);
1880                     RETURN;
1881                 }
1882                 buv = SvUVX(TOPs);
1883                 SP--;
1884                 SETs(boolSV((UV)aiv > buv));
1885                 RETURN;
1886             }
1887         }
1888     }
1889 #endif
1890 #ifndef NV_PRESERVES_UV
1891 #ifdef PERL_PRESERVE_IVUV
1892     else
1893 #endif
1894     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1895         SP--;
1896         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1897         RETURN;
1898     }
1899 #endif
1900     {
1901 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1902       dPOPTOPnnrl;
1903       if (Perl_isnan(left) || Perl_isnan(right))
1904           RETSETNO;
1905       SETs(boolSV(left > right));
1906 #else
1907       dPOPnv;
1908       SETs(boolSV(TOPn > value));
1909 #endif
1910       RETURN;
1911     }
1912 }
1913
1914 PP(pp_le)
1915 {
1916     dVAR; dSP; tryAMAGICbinSET(le,0);
1917 #ifdef PERL_PRESERVE_IVUV
1918     SvIV_please(TOPs);
1919     if (SvIOK(TOPs)) {
1920         SvIV_please(TOPm1s);
1921         if (SvIOK(TOPm1s)) {
1922             bool auvok = SvUOK(TOPm1s);
1923             bool buvok = SvUOK(TOPs);
1924
1925             if (!auvok && !buvok) { /* ## IV <= IV ## */
1926                 const IV aiv = SvIVX(TOPm1s);
1927                 const IV biv = SvIVX(TOPs);
1928
1929                 SP--;
1930                 SETs(boolSV(aiv <= biv));
1931                 RETURN;
1932             }
1933             if (auvok && buvok) { /* ## UV <= UV ## */
1934                 UV auv = SvUVX(TOPm1s);
1935                 UV buv = SvUVX(TOPs);
1936
1937                 SP--;
1938                 SETs(boolSV(auv <= buv));
1939                 RETURN;
1940             }
1941             if (auvok) { /* ## UV <= IV ## */
1942                 UV auv;
1943                 const IV biv = SvIVX(TOPs);
1944
1945                 SP--;
1946                 if (biv < 0) {
1947                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1948                     SETs(&PL_sv_no);
1949                     RETURN;
1950                 }
1951                 auv = SvUVX(TOPs);
1952                 SETs(boolSV(auv <= (UV)biv));
1953                 RETURN;
1954             }
1955             { /* ## IV <= UV ## */
1956                 const IV aiv = SvIVX(TOPm1s);
1957                 UV buv;
1958
1959                 if (aiv < 0) {
1960                     /* As (b) is a UV, it's >=0, so a must be <= */
1961                     SP--;
1962                     SETs(&PL_sv_yes);
1963                     RETURN;
1964                 }
1965                 buv = SvUVX(TOPs);
1966                 SP--;
1967                 SETs(boolSV((UV)aiv <= buv));
1968                 RETURN;
1969             }
1970         }
1971     }
1972 #endif
1973 #ifndef NV_PRESERVES_UV
1974 #ifdef PERL_PRESERVE_IVUV
1975     else
1976 #endif
1977     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1978         SP--;
1979         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1980         RETURN;
1981     }
1982 #endif
1983     {
1984 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1985       dPOPTOPnnrl;
1986       if (Perl_isnan(left) || Perl_isnan(right))
1987           RETSETNO;
1988       SETs(boolSV(left <= right));
1989 #else
1990       dPOPnv;
1991       SETs(boolSV(TOPn <= value));
1992 #endif
1993       RETURN;
1994     }
1995 }
1996
1997 PP(pp_ge)
1998 {
1999     dVAR; dSP; tryAMAGICbinSET(ge,0);
2000 #ifdef PERL_PRESERVE_IVUV
2001     SvIV_please(TOPs);
2002     if (SvIOK(TOPs)) {
2003         SvIV_please(TOPm1s);
2004         if (SvIOK(TOPm1s)) {
2005             bool auvok = SvUOK(TOPm1s);
2006             bool buvok = SvUOK(TOPs);
2007
2008             if (!auvok && !buvok) { /* ## IV >= IV ## */
2009                 const IV aiv = SvIVX(TOPm1s);
2010                 const IV biv = SvIVX(TOPs);
2011
2012                 SP--;
2013                 SETs(boolSV(aiv >= biv));
2014                 RETURN;
2015             }
2016             if (auvok && buvok) { /* ## UV >= UV ## */
2017                 const UV auv = SvUVX(TOPm1s);
2018                 const UV buv = SvUVX(TOPs);
2019
2020                 SP--;
2021                 SETs(boolSV(auv >= buv));
2022                 RETURN;
2023             }
2024             if (auvok) { /* ## UV >= IV ## */
2025                 UV auv;
2026                 const IV biv = SvIVX(TOPs);
2027
2028                 SP--;
2029                 if (biv < 0) {
2030                     /* As (a) is a UV, it's >=0, so it must be >= */
2031                     SETs(&PL_sv_yes);
2032                     RETURN;
2033                 }
2034                 auv = SvUVX(TOPs);
2035                 SETs(boolSV(auv >= (UV)biv));
2036                 RETURN;
2037             }
2038             { /* ## IV >= UV ## */
2039                 const IV aiv = SvIVX(TOPm1s);
2040                 UV buv;
2041
2042                 if (aiv < 0) {
2043                     /* As (b) is a UV, it's >=0, so a cannot be >= */
2044                     SP--;
2045                     SETs(&PL_sv_no);
2046                     RETURN;
2047                 }
2048                 buv = SvUVX(TOPs);
2049                 SP--;
2050                 SETs(boolSV((UV)aiv >= buv));
2051                 RETURN;
2052             }
2053         }
2054     }
2055 #endif
2056 #ifndef NV_PRESERVES_UV
2057 #ifdef PERL_PRESERVE_IVUV
2058     else
2059 #endif
2060     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2061         SP--;
2062         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2063         RETURN;
2064     }
2065 #endif
2066     {
2067 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2068       dPOPTOPnnrl;
2069       if (Perl_isnan(left) || Perl_isnan(right))
2070           RETSETNO;
2071       SETs(boolSV(left >= right));
2072 #else
2073       dPOPnv;
2074       SETs(boolSV(TOPn >= value));
2075 #endif
2076       RETURN;
2077     }
2078 }
2079
2080 PP(pp_ne)
2081 {
2082     dVAR; dSP; tryAMAGICbinSET(ne,0);
2083 #ifndef NV_PRESERVES_UV
2084     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2085         SP--;
2086         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2087         RETURN;
2088     }
2089 #endif
2090 #ifdef PERL_PRESERVE_IVUV
2091     SvIV_please(TOPs);
2092     if (SvIOK(TOPs)) {
2093         SvIV_please(TOPm1s);
2094         if (SvIOK(TOPm1s)) {
2095             const bool auvok = SvUOK(TOPm1s);
2096             const bool buvok = SvUOK(TOPs);
2097
2098             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2099                 /* Casting IV to UV before comparison isn't going to matter
2100                    on 2s complement. On 1s complement or sign&magnitude
2101                    (if we have any of them) it could make negative zero
2102                    differ from normal zero. As I understand it. (Need to
2103                    check - is negative zero implementation defined behaviour
2104                    anyway?). NWC  */
2105                 const UV buv = SvUVX(POPs);
2106                 const UV auv = SvUVX(TOPs);
2107
2108                 SETs(boolSV(auv != buv));
2109                 RETURN;
2110             }
2111             {                   /* ## Mixed IV,UV ## */
2112                 IV iv;
2113                 UV uv;
2114
2115                 /* != is commutative so swap if needed (save code) */
2116                 if (auvok) {
2117                     /* swap. top of stack (b) is the iv */
2118                     iv = SvIVX(TOPs);
2119                     SP--;
2120                     if (iv < 0) {
2121                         /* As (a) is a UV, it's >0, so it cannot be == */
2122                         SETs(&PL_sv_yes);
2123                         RETURN;
2124                     }
2125                     uv = SvUVX(TOPs);
2126                 } else {
2127                     iv = SvIVX(TOPm1s);
2128                     SP--;
2129                     if (iv < 0) {
2130                         /* As (b) is a UV, it's >0, so it cannot be == */
2131                         SETs(&PL_sv_yes);
2132                         RETURN;
2133                     }
2134                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2135                 }
2136                 SETs(boolSV((UV)iv != uv));
2137                 RETURN;
2138             }
2139         }
2140     }
2141 #endif
2142     {
2143 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2144       dPOPTOPnnrl;
2145       if (Perl_isnan(left) || Perl_isnan(right))
2146           RETSETYES;
2147       SETs(boolSV(left != right));
2148 #else
2149       dPOPnv;
2150       SETs(boolSV(TOPn != value));
2151 #endif
2152       RETURN;
2153     }
2154 }
2155
2156 PP(pp_ncmp)
2157 {
2158     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2159 #ifndef NV_PRESERVES_UV
2160     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2161         const UV right = PTR2UV(SvRV(POPs));
2162         const UV left = PTR2UV(SvRV(TOPs));
2163         SETi((left > right) - (left < right));
2164         RETURN;
2165     }
2166 #endif
2167 #ifdef PERL_PRESERVE_IVUV
2168     /* Fortunately it seems NaN isn't IOK */
2169     SvIV_please(TOPs);
2170     if (SvIOK(TOPs)) {
2171         SvIV_please(TOPm1s);
2172         if (SvIOK(TOPm1s)) {
2173             const bool leftuvok = SvUOK(TOPm1s);
2174             const bool rightuvok = SvUOK(TOPs);
2175             I32 value;
2176             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2177                 const IV leftiv = SvIVX(TOPm1s);
2178                 const IV rightiv = SvIVX(TOPs);
2179
2180                 if (leftiv > rightiv)
2181                     value = 1;
2182                 else if (leftiv < rightiv)
2183                     value = -1;
2184                 else
2185                     value = 0;
2186             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2187                 const UV leftuv = SvUVX(TOPm1s);
2188                 const UV rightuv = SvUVX(TOPs);
2189
2190                 if (leftuv > rightuv)
2191                     value = 1;
2192                 else if (leftuv < rightuv)
2193                     value = -1;
2194                 else
2195                     value = 0;
2196             } else if (leftuvok) { /* ## UV <=> IV ## */
2197                 const IV rightiv = SvIVX(TOPs);
2198                 if (rightiv < 0) {
2199                     /* As (a) is a UV, it's >=0, so it cannot be < */
2200                     value = 1;
2201                 } else {
2202                     const UV leftuv = SvUVX(TOPm1s);
2203                     if (leftuv > (UV)rightiv) {
2204                         value = 1;
2205                     } else if (leftuv < (UV)rightiv) {
2206                         value = -1;
2207                     } else {
2208                         value = 0;
2209                     }
2210                 }
2211             } else { /* ## IV <=> UV ## */
2212                 const IV leftiv = SvIVX(TOPm1s);
2213                 if (leftiv < 0) {
2214                     /* As (b) is a UV, it's >=0, so it must be < */
2215                     value = -1;
2216                 } else {
2217                     const UV rightuv = SvUVX(TOPs);
2218                     if ((UV)leftiv > rightuv) {
2219                         value = 1;
2220                     } else if ((UV)leftiv < rightuv) {
2221                         value = -1;
2222                     } else {
2223                         value = 0;
2224                     }
2225                 }
2226             }
2227             SP--;
2228             SETi(value);
2229             RETURN;
2230         }
2231     }
2232 #endif
2233     {
2234       dPOPTOPnnrl;
2235       I32 value;
2236
2237 #ifdef Perl_isnan
2238       if (Perl_isnan(left) || Perl_isnan(right)) {
2239           SETs(&PL_sv_undef);
2240           RETURN;
2241        }
2242       value = (left > right) - (left < right);
2243 #else
2244       if (left == right)
2245         value = 0;
2246       else if (left < right)
2247         value = -1;
2248       else if (left > right)
2249         value = 1;
2250       else {
2251         SETs(&PL_sv_undef);
2252         RETURN;
2253       }
2254 #endif
2255       SETi(value);
2256       RETURN;
2257     }
2258 }
2259
2260 PP(pp_sle)
2261 {
2262     dVAR; dSP;
2263
2264     int amg_type = sle_amg;
2265     int multiplier = 1;
2266     int rhs = 1;
2267
2268     switch (PL_op->op_type) {
2269     case OP_SLT:
2270         amg_type = slt_amg;
2271         /* cmp < 0 */
2272         rhs = 0;
2273         break;
2274     case OP_SGT:
2275         amg_type = sgt_amg;
2276         /* cmp > 0 */
2277         multiplier = -1;
2278         rhs = 0;
2279         break;
2280     case OP_SGE:
2281         amg_type = sge_amg;
2282         /* cmp >= 0 */
2283         multiplier = -1;
2284         break;
2285     }
2286
2287     tryAMAGICbinSET_var(amg_type,0);
2288     {
2289       dPOPTOPssrl;
2290       const int cmp = (IN_LOCALE_RUNTIME
2291                  ? sv_cmp_locale(left, right)
2292                  : sv_cmp(left, right));
2293       SETs(boolSV(cmp * multiplier < rhs));
2294       RETURN;
2295     }
2296 }
2297
2298 PP(pp_seq)
2299 {
2300     dVAR; dSP; tryAMAGICbinSET(seq,0);
2301     {
2302       dPOPTOPssrl;
2303       SETs(boolSV(sv_eq(left, right)));
2304       RETURN;
2305     }
2306 }
2307
2308 PP(pp_sne)
2309 {
2310     dVAR; dSP; tryAMAGICbinSET(sne,0);
2311     {
2312       dPOPTOPssrl;
2313       SETs(boolSV(!sv_eq(left, right)));
2314       RETURN;
2315     }
2316 }
2317
2318 PP(pp_scmp)
2319 {
2320     dVAR; dSP; dTARGET;  tryAMAGICbin(scmp,0);
2321     {
2322       dPOPTOPssrl;
2323       const int cmp = (IN_LOCALE_RUNTIME
2324                  ? sv_cmp_locale(left, right)
2325                  : sv_cmp(left, right));
2326       SETi( cmp );
2327       RETURN;
2328     }
2329 }
2330
2331 PP(pp_bit_and)
2332 {
2333     dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2334     {
2335       dPOPTOPssrl;
2336       SvGETMAGIC(left);
2337       SvGETMAGIC(right);
2338       if (SvNIOKp(left) || SvNIOKp(right)) {
2339         if (PL_op->op_private & HINT_INTEGER) {
2340           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2341           SETi(i);
2342         }
2343         else {
2344           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2345           SETu(u);
2346         }
2347       }
2348       else {
2349         do_vop(PL_op->op_type, TARG, left, right);
2350         SETTARG;
2351       }
2352       RETURN;
2353     }
2354 }
2355
2356 PP(pp_bit_or)
2357 {
2358     dVAR; dSP; dATARGET;
2359     const int op_type = PL_op->op_type;
2360
2361     tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2362     {
2363       dPOPTOPssrl;
2364       SvGETMAGIC(left);
2365       SvGETMAGIC(right);
2366       if (SvNIOKp(left) || SvNIOKp(right)) {
2367         if (PL_op->op_private & HINT_INTEGER) {
2368           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2369           const IV r = SvIV_nomg(right);
2370           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2371           SETi(result);
2372         }
2373         else {
2374           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2375           const UV r = SvUV_nomg(right);
2376           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2377           SETu(result);
2378         }
2379       }
2380       else {
2381         do_vop(op_type, TARG, left, right);
2382         SETTARG;
2383       }
2384       RETURN;
2385     }
2386 }
2387
2388 PP(pp_negate)
2389 {
2390     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2391     {
2392         SV * const sv = sv_2num(TOPs);
2393         const int flags = SvFLAGS(sv);
2394         SvGETMAGIC(sv);
2395         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2396             /* It's publicly an integer, or privately an integer-not-float */
2397         oops_its_an_int:
2398             if (SvIsUV(sv)) {
2399                 if (SvIVX(sv) == IV_MIN) {
2400                     /* 2s complement assumption. */
2401                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2402                     RETURN;
2403                 }
2404                 else if (SvUVX(sv) <= IV_MAX) {
2405                     SETi(-SvIVX(sv));
2406                     RETURN;
2407                 }
2408             }
2409             else if (SvIVX(sv) != IV_MIN) {
2410                 SETi(-SvIVX(sv));
2411                 RETURN;
2412             }
2413 #ifdef PERL_PRESERVE_IVUV
2414             else {
2415                 SETu((UV)IV_MIN);
2416                 RETURN;
2417             }
2418 #endif
2419         }
2420         if (SvNIOKp(sv))
2421             SETn(-SvNV(sv));
2422         else if (SvPOKp(sv)) {
2423             STRLEN len;
2424             const char * const s = SvPV_const(sv, len);
2425             if (isIDFIRST(*s)) {
2426                 sv_setpvn(TARG, "-", 1);
2427                 sv_catsv(TARG, sv);
2428             }
2429             else if (*s == '+' || *s == '-') {
2430                 sv_setsv(TARG, sv);
2431                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2432             }
2433             else if (DO_UTF8(sv)) {
2434                 SvIV_please(sv);
2435                 if (SvIOK(sv))
2436                     goto oops_its_an_int;
2437                 if (SvNOK(sv))
2438                     sv_setnv(TARG, -SvNV(sv));
2439                 else {
2440                     sv_setpvn(TARG, "-", 1);
2441                     sv_catsv(TARG, sv);
2442                 }
2443             }
2444             else {
2445                 SvIV_please(sv);
2446                 if (SvIOK(sv))
2447                   goto oops_its_an_int;
2448                 sv_setnv(TARG, -SvNV(sv));
2449             }
2450             SETTARG;
2451         }
2452         else
2453             SETn(-SvNV(sv));
2454     }
2455     RETURN;
2456 }
2457
2458 PP(pp_not)
2459 {
2460     dVAR; dSP; tryAMAGICunSET(not);
2461     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2462     return NORMAL;
2463 }
2464
2465 PP(pp_complement)
2466 {
2467     dVAR; dSP; dTARGET; tryAMAGICun(compl);
2468     {
2469       dTOPss;
2470       SvGETMAGIC(sv);
2471       if (SvNIOKp(sv)) {
2472         if (PL_op->op_private & HINT_INTEGER) {
2473           const IV i = ~SvIV_nomg(sv);
2474           SETi(i);
2475         }
2476         else {
2477           const UV u = ~SvUV_nomg(sv);
2478           SETu(u);
2479         }
2480       }
2481       else {
2482         register U8 *tmps;
2483         register I32 anum;
2484         STRLEN len;
2485
2486         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2487         sv_setsv_nomg(TARG, sv);
2488         tmps = (U8*)SvPV_force(TARG, len);
2489         anum = len;
2490         if (SvUTF8(TARG)) {
2491           /* Calculate exact length, let's not estimate. */
2492           STRLEN targlen = 0;
2493           STRLEN l;
2494           UV nchar = 0;
2495           UV nwide = 0;
2496           U8 * const send = tmps + len;
2497           U8 * const origtmps = tmps;
2498           const UV utf8flags = UTF8_ALLOW_ANYUV;
2499
2500           while (tmps < send) {
2501             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2502             tmps += l;
2503             targlen += UNISKIP(~c);
2504             nchar++;
2505             if (c > 0xff)
2506                 nwide++;
2507           }
2508
2509           /* Now rewind strings and write them. */
2510           tmps = origtmps;
2511
2512           if (nwide) {
2513               U8 *result;
2514               U8 *p;
2515
2516               Newx(result, targlen + 1, U8);
2517               p = result;
2518               while (tmps < send) {
2519                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2520                   tmps += l;
2521                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2522               }
2523               *p = '\0';
2524               sv_usepvn_flags(TARG, (char*)result, targlen,
2525                               SV_HAS_TRAILING_NUL);
2526               SvUTF8_on(TARG);
2527           }
2528           else {
2529               U8 *result;
2530               U8 *p;
2531
2532               Newx(result, nchar + 1, U8);
2533               p = result;
2534               while (tmps < send) {
2535                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2536                   tmps += l;
2537                   *p++ = ~c;
2538               }
2539               *p = '\0';
2540               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2541               SvUTF8_off(TARG);
2542           }
2543           SETs(TARG);
2544           RETURN;
2545         }
2546 #ifdef LIBERAL
2547         {
2548             register long *tmpl;
2549             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2550                 *tmps = ~*tmps;
2551             tmpl = (long*)tmps;
2552             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2553                 *tmpl = ~*tmpl;
2554             tmps = (U8*)tmpl;
2555         }
2556 #endif
2557         for ( ; anum > 0; anum--, tmps++)
2558             *tmps = ~*tmps;
2559
2560         SETs(TARG);
2561       }
2562       RETURN;
2563     }
2564 }
2565
2566 /* integer versions of some of the above */
2567
2568 PP(pp_i_multiply)
2569 {
2570     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2571     {
2572       dPOPTOPiirl;
2573       SETi( left * right );
2574       RETURN;
2575     }
2576 }
2577
2578 PP(pp_i_divide)
2579 {
2580     IV num;
2581     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2582     {
2583       dPOPiv;
2584       if (value == 0)
2585           DIE(aTHX_ "Illegal division by zero");
2586       num = POPi;
2587
2588       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2589       if (value == -1)
2590           value = - num;
2591       else
2592           value = num / value;
2593       PUSHi( value );
2594       RETURN;
2595     }
2596 }
2597
2598 #if defined(__GLIBC__) && IVSIZE == 8
2599 STATIC
2600 PP(pp_i_modulo_0)
2601 #else
2602 PP(pp_i_modulo)
2603 #endif
2604 {
2605      /* This is the vanilla old i_modulo. */
2606      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2607      {
2608           dPOPTOPiirl;
2609           if (!right)
2610                DIE(aTHX_ "Illegal modulus zero");
2611           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2612           if (right == -1)
2613               SETi( 0 );
2614           else
2615               SETi( left % right );
2616           RETURN;
2617      }
2618 }
2619
2620 #if defined(__GLIBC__) && IVSIZE == 8
2621 STATIC
2622 PP(pp_i_modulo_1)
2623
2624 {
2625      /* This is the i_modulo with the workaround for the _moddi3 bug
2626       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2627       * See below for pp_i_modulo. */
2628      dVAR; 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_utf8(big_p, biglen, big_utf8));
3316         big_p = SvPVX(big);
3317     }
3318     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3319         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3320            warn on undef, and we've already triggered a warning with the
3321            SvPV_const some lines above. We can't remove that, as we need to
3322            call some SvPV to trigger overloading early and find out if the
3323            string is UTF-8.
3324            This is all getting to messy. The API isn't quite clean enough,
3325            because data access has side effects.
3326         */
3327         little = sv_2mortal(newSVpvn_utf8(little_p, llen, little_utf8));
3328         little_p = SvPVX(little);
3329     }
3330
3331     if (MAXARG < 3)
3332         offset = is_index ? 0 : biglen;
3333     else {
3334         if (big_utf8 && offset > 0)
3335             sv_pos_u2b(big, &offset, 0);
3336         if (!is_index)
3337             offset += llen;
3338     }
3339     if (offset < 0)
3340         offset = 0;
3341     else if (offset > (I32)biglen)
3342         offset = biglen;
3343     if (!(little_p = is_index
3344           ? fbm_instr((unsigned char*)big_p + offset,
3345                       (unsigned char*)big_p + biglen, little, 0)
3346           : rninstr(big_p,  big_p  + offset,
3347                     little_p, little_p + llen)))
3348         retval = -1;
3349     else {
3350         retval = little_p - big_p;
3351         if (retval > 0 && big_utf8)
3352             sv_pos_b2u(big, &retval);
3353     }
3354     if (temp)
3355         SvREFCNT_dec(temp);
3356  fail:
3357     PUSHi(retval + arybase);
3358     RETURN;
3359 }
3360
3361 PP(pp_sprintf)
3362 {
3363     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3364     if (SvTAINTED(MARK[1]))
3365         TAINT_PROPER("sprintf");
3366     do_sprintf(TARG, SP-MARK, MARK+1);
3367     TAINT_IF(SvTAINTED(TARG));
3368     SP = ORIGMARK;
3369     PUSHTARG;
3370     RETURN;
3371 }
3372
3373 PP(pp_ord)
3374 {
3375     dVAR; dSP; dTARGET;
3376
3377     SV *argsv = POPs;
3378     STRLEN len;
3379     const U8 *s = (U8*)SvPV_const(argsv, len);
3380
3381     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3382         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3383         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3384         argsv = tmpsv;
3385     }
3386
3387     XPUSHu(DO_UTF8(argsv) ?
3388            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3389            (UV)(*s & 0xff));
3390
3391     RETURN;
3392 }
3393
3394 PP(pp_chr)
3395 {
3396     dVAR; dSP; dTARGET;
3397     char *tmps;
3398     UV value;
3399
3400     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3401          ||
3402          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3403         if (IN_BYTES) {
3404             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3405         } else {
3406             (void) POPs; /* Ignore the argument value. */
3407             value = UNICODE_REPLACEMENT;
3408         }
3409     } else {
3410         value = POPu;
3411     }
3412
3413     SvUPGRADE(TARG,SVt_PV);
3414
3415     if (value > 255 && !IN_BYTES) {
3416         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3417         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3418         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3419         *tmps = '\0';
3420         (void)SvPOK_only(TARG);
3421         SvUTF8_on(TARG);
3422         XPUSHs(TARG);
3423         RETURN;
3424     }
3425
3426     SvGROW(TARG,2);
3427     SvCUR_set(TARG, 1);
3428     tmps = SvPVX(TARG);
3429     *tmps++ = (char)value;
3430     *tmps = '\0';
3431     (void)SvPOK_only(TARG);
3432
3433     if (PL_encoding && !IN_BYTES) {
3434         sv_recode_to_utf8(TARG, PL_encoding);
3435         tmps = SvPVX(TARG);
3436         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3437             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3438             SvGROW(TARG, 2);
3439             tmps = SvPVX(TARG);
3440             SvCUR_set(TARG, 1);
3441             *tmps++ = (char)value;
3442             *tmps = '\0';
3443             SvUTF8_off(TARG);
3444         }
3445     }
3446
3447     XPUSHs(TARG);
3448     RETURN;
3449 }
3450
3451 PP(pp_crypt)
3452 {
3453 #ifdef HAS_CRYPT
3454     dVAR; dSP; dTARGET;
3455     dPOPTOPssrl;
3456     STRLEN len;
3457     const char *tmps = SvPV_const(left, len);
3458
3459     if (DO_UTF8(left)) {
3460          /* If Unicode, try to downgrade.
3461           * If not possible, croak.
3462           * Yes, we made this up.  */
3463          SV* const tsv = sv_2mortal(newSVsv(left));
3464
3465          SvUTF8_on(tsv);
3466          sv_utf8_downgrade(tsv, FALSE);
3467          tmps = SvPV_const(tsv, len);
3468     }
3469 #   ifdef USE_ITHREADS
3470 #     ifdef HAS_CRYPT_R
3471     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3472       /* This should be threadsafe because in ithreads there is only
3473        * one thread per interpreter.  If this would not be true,
3474        * we would need a mutex to protect this malloc. */
3475         PL_reentrant_buffer->_crypt_struct_buffer =
3476           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3477 #if defined(__GLIBC__) || defined(__EMX__)
3478         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3479             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3480             /* work around glibc-2.2.5 bug */
3481             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3482         }
3483 #endif
3484     }
3485 #     endif /* HAS_CRYPT_R */
3486 #   endif /* USE_ITHREADS */
3487 #   ifdef FCRYPT
3488     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3489 #   else
3490     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3491 #   endif
3492     SETs(TARG);
3493     RETURN;
3494 #else
3495     DIE(aTHX_
3496       "The crypt() function is unimplemented due to excessive paranoia.");
3497 #endif
3498 }
3499
3500 PP(pp_ucfirst)
3501 {
3502     dVAR;
3503     dSP;
3504     SV *source = TOPs;
3505     STRLEN slen;
3506     STRLEN need;
3507     SV *dest;
3508     bool inplace = TRUE;
3509     bool doing_utf8;
3510     const int op_type = PL_op->op_type;
3511     const U8 *s;
3512     U8 *d;
3513     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3514     STRLEN ulen;
3515     STRLEN tculen;
3516
3517     SvGETMAGIC(source);
3518     if (SvOK(source)) {
3519         s = (const U8*)SvPV_nomg_const(source, slen);
3520     } else {
3521         s = (const U8*)"";
3522         slen = 0;
3523     }
3524
3525     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3526         doing_utf8 = TRUE;
3527         utf8_to_uvchr(s, &ulen);
3528         if (op_type == OP_UCFIRST) {
3529             toTITLE_utf8(s, tmpbuf, &tculen);
3530         } else {
3531             toLOWER_utf8(s, tmpbuf, &tculen);
3532         }
3533         /* If the two differ, we definately cannot do inplace.  */
3534         inplace = (ulen == tculen);
3535         need = slen + 1 - ulen + tculen;
3536     } else {
3537         doing_utf8 = FALSE;
3538         need = slen + 1;
3539     }
3540
3541     if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3542         /* We can convert in place.  */
3543
3544         dest = source;
3545         s = d = (U8*)SvPV_force_nomg(source, slen);
3546     } else {
3547         dTARGET;
3548
3549         dest = TARG;
3550
3551         SvUPGRADE(dest, SVt_PV);
3552         d = (U8*)SvGROW(dest, need);
3553         (void)SvPOK_only(dest);
3554
3555         SETs(dest);
3556
3557         inplace = FALSE;
3558     }
3559
3560     if (doing_utf8) {
3561         if(!inplace) {
3562             /* slen is the byte length of the whole SV.
3563              * ulen is the byte length of the original Unicode character
3564              * stored as UTF-8 at s.
3565              * tculen is the byte length of the freshly titlecased (or
3566              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3567              * We first set the result to be the titlecased (/lowercased)
3568              * character, and then append the rest of the SV data. */
3569             sv_setpvn(dest, (char*)tmpbuf, tculen);
3570             if (slen > ulen)
3571                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3572             SvUTF8_on(dest);
3573         }
3574         else {
3575             Copy(tmpbuf, d, tculen, U8);
3576             SvCUR_set(dest, need - 1);
3577         }
3578     }
3579     else {
3580         if (*s) {
3581             if (IN_LOCALE_RUNTIME) {
3582                 TAINT;
3583                 SvTAINTED_on(dest);
3584                 *d = (op_type == OP_UCFIRST)
3585                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3586             }
3587             else
3588                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3589         } else {
3590             /* See bug #39028  */
3591             *d = *s;
3592         }
3593
3594         if (SvUTF8(source))
3595             SvUTF8_on(dest);
3596
3597         if (!inplace) {
3598             /* This will copy the trailing NUL  */
3599             Copy(s + 1, d + 1, slen, U8);
3600             SvCUR_set(dest, need - 1);
3601         }
3602     }
3603     SvSETMAGIC(dest);
3604     RETURN;
3605 }
3606
3607 /* There's so much setup/teardown code common between uc and lc, I wonder if
3608    it would be worth merging the two, and just having a switch outside each
3609    of the three tight loops.  */
3610 PP(pp_uc)
3611 {
3612     dVAR;
3613     dSP;
3614     SV *source = TOPs;
3615     STRLEN len;
3616     STRLEN min;
3617     SV *dest;
3618     const U8 *s;
3619     U8 *d;
3620
3621     SvGETMAGIC(source);
3622
3623     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3624         && SvTEMP(source) && !DO_UTF8(source)) {
3625         /* We can convert in place.  */
3626
3627         dest = source;
3628         s = d = (U8*)SvPV_force_nomg(source, len);
3629         min = len + 1;
3630     } else {
3631         dTARGET;
3632
3633         dest = TARG;
3634
3635         /* The old implementation would copy source into TARG at this point.
3636            This had the side effect that if source was undef, TARG was now
3637            an undefined SV with PADTMP set, and they don't warn inside
3638            sv_2pv_flags(). However, we're now getting the PV direct from
3639            source, which doesn't have PADTMP set, so it would warn. Hence the
3640            little games.  */
3641
3642         if (SvOK(source)) {
3643             s = (const U8*)SvPV_nomg_const(source, len);
3644         } else {
3645             s = (const U8*)"";
3646             len = 0;
3647         }
3648         min = len + 1;
3649
3650         SvUPGRADE(dest, SVt_PV);
3651         d = (U8*)SvGROW(dest, min);
3652         (void)SvPOK_only(dest);
3653
3654         SETs(dest);
3655     }
3656
3657     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3658        to check DO_UTF8 again here.  */
3659
3660     if (DO_UTF8(source)) {
3661         const U8 *const send = s + len;
3662         U8 tmpbuf[UTF8_MAXBYTES+1];
3663
3664         while (s < send) {
3665             const STRLEN u = UTF8SKIP(s);
3666             STRLEN ulen;
3667
3668             toUPPER_utf8(s, tmpbuf, &ulen);
3669             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3670                 /* If the eventually required minimum size outgrows
3671                  * the available space, we need to grow. */
3672                 const UV o = d - (U8*)SvPVX_const(dest);
3673
3674                 /* If someone uppercases one million U+03B0s we SvGROW() one
3675                  * million times.  Or we could try guessing how much to
3676                  allocate without allocating too much.  Such is life. */
3677                 SvGROW(dest, min);
3678                 d = (U8*)SvPVX(dest) + o;
3679             }
3680             Copy(tmpbuf, d, ulen, U8);
3681             d += ulen;
3682             s += u;
3683         }
3684         SvUTF8_on(dest);
3685         *d = '\0';
3686         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3687     } else {
3688         if (len) {
3689             const U8 *const send = s + len;
3690             if (IN_LOCALE_RUNTIME) {
3691                 TAINT;
3692                 SvTAINTED_on(dest);
3693                 for (; s < send; d++, s++)
3694                     *d = toUPPER_LC(*s);
3695             }
3696             else {
3697                 for (; s < send; d++, s++)
3698                     *d = toUPPER(*s);
3699             }
3700         }
3701         if (source != dest) {
3702             *d = '\0';
3703             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3704         }
3705     }
3706     SvSETMAGIC(dest);
3707     RETURN;
3708 }
3709
3710 PP(pp_lc)
3711 {
3712     dVAR;
3713     dSP;
3714     SV *source = TOPs;
3715     STRLEN len;
3716     STRLEN min;
3717     SV *dest;
3718     const U8 *s;
3719     U8 *d;
3720
3721     SvGETMAGIC(source);
3722
3723     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3724         && SvTEMP(source) && !DO_UTF8(source)) {
3725         /* We can convert in place.  */
3726
3727         dest = source;
3728         s = d = (U8*)SvPV_force_nomg(source, len);
3729         min = len + 1;
3730     } else {
3731         dTARGET;
3732
3733         dest = TARG;
3734
3735         /* The old implementation would copy source into TARG at this point.
3736            This had the side effect that if source was undef, TARG was now
3737            an undefined SV with PADTMP set, and they don't warn inside
3738            sv_2pv_flags(). However, we're now getting the PV direct from
3739            source, which doesn't have PADTMP set, so it would warn. Hence the
3740            little games.  */
3741
3742         if (SvOK(source)) {
3743             s = (const U8*)SvPV_nomg_const(source, len);
3744         } else {
3745             s = (const U8*)"";
3746             len = 0;
3747         }
3748         min = len + 1;
3749
3750         SvUPGRADE(dest, SVt_PV);
3751         d = (U8*)SvGROW(dest, min);
3752         (void)SvPOK_only(dest);
3753
3754         SETs(dest);
3755     }
3756
3757     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3758        to check DO_UTF8 again here.  */
3759
3760     if (DO_UTF8(source)) {
3761         const U8 *const send = s + len;
3762         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3763
3764         while (s < send) {
3765             const STRLEN u = UTF8SKIP(s);
3766             STRLEN ulen;
3767             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3768
3769 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3770             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3771                 NOOP;
3772                 /*
3773                  * Now if the sigma is NOT followed by
3774                  * /$ignorable_sequence$cased_letter/;
3775                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3776                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3777                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3778                  * then it should be mapped to 0x03C2,
3779                  * (GREEK SMALL LETTER FINAL SIGMA),
3780                  * instead of staying 0x03A3.
3781                  * "should be": in other words, this is not implemented yet.
3782                  * See lib/unicore/SpecialCasing.txt.
3783                  */
3784             }
3785             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3786                 /* If the eventually required minimum size outgrows
3787                  * the available space, we need to grow. */
3788                 const UV o = d - (U8*)SvPVX_const(dest);
3789
3790                 /* If someone lowercases one million U+0130s we SvGROW() one
3791                  * million times.  Or we could try guessing how much to
3792                  allocate without allocating too much.  Such is life. */
3793                 SvGROW(dest, min);
3794                 d = (U8*)SvPVX(dest) + o;
3795             }
3796             Copy(tmpbuf, d, ulen, U8);
3797             d += ulen;
3798             s += u;
3799         }
3800         SvUTF8_on(dest);
3801         *d = '\0';
3802         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3803     } else {
3804         if (len) {
3805             const U8 *const send = s + len;
3806             if (IN_LOCALE_RUNTIME) {
3807                 TAINT;
3808                 SvTAINTED_on(dest);
3809                 for (; s < send; d++, s++)
3810                     *d = toLOWER_LC(*s);
3811             }
3812             else {
3813                 for (; s < send; d++, s++)
3814                     *d = toLOWER(*s);
3815             }
3816         }
3817         if (source != dest) {
3818             *d = '\0';
3819             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3820         }
3821     }
3822     SvSETMAGIC(dest);
3823     RETURN;
3824 }
3825
3826 PP(pp_quotemeta)
3827 {
3828     dVAR; dSP; dTARGET;
3829     SV * const sv = TOPs;
3830     STRLEN len;
3831     register const char *s = SvPV_const(sv,len);
3832
3833     SvUTF8_off(TARG);                           /* decontaminate */
3834     if (len) {
3835         register char *d;
3836         SvUPGRADE(TARG, SVt_PV);
3837         SvGROW(TARG, (len * 2) + 1);
3838         d = SvPVX(TARG);
3839         if (DO_UTF8(sv)) {
3840             while (len) {
3841                 if (UTF8_IS_CONTINUED(*s)) {
3842                     STRLEN ulen = UTF8SKIP(s);
3843                     if (ulen > len)
3844                         ulen = len;
3845                     len -= ulen;
3846                     while (ulen--)
3847                         *d++ = *s++;
3848                 }
3849                 else {
3850                     if (!isALNUM(*s))
3851                         *d++ = '\\';
3852                     *d++ = *s++;
3853                     len--;
3854                 }
3855             }
3856             SvUTF8_on(TARG);
3857         }
3858         else {
3859             while (len--) {
3860                 if (!isALNUM(*s))
3861                     *d++ = '\\';
3862                 *d++ = *s++;
3863             }
3864         }
3865         *d = '\0';
3866         SvCUR_set(TARG, d - SvPVX_const(TARG));
3867         (void)SvPOK_only_UTF8(TARG);
3868     }
3869     else
3870         sv_setpvn(TARG, s, len);
3871     SETs(TARG);
3872     if (SvSMAGICAL(TARG))
3873         mg_set(TARG);
3874     RETURN;
3875 }
3876
3877 /* Arrays. */
3878
3879 PP(pp_aslice)
3880 {
3881     dVAR; dSP; dMARK; dORIGMARK;
3882     register AV* const av = (AV*)POPs;
3883     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3884
3885     if (SvTYPE(av) == SVt_PVAV) {
3886         const I32 arybase = CopARYBASE_get(PL_curcop);
3887         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3888             register SV **svp;
3889             I32 max = -1;
3890             for (svp = MARK + 1; svp <= SP; svp++) {
3891                 const I32 elem = SvIV(*svp);
3892                 if (elem > max)
3893                     max = elem;
3894             }
3895             if (max > AvMAX(av))
3896                 av_extend(av, max);
3897         }
3898         while (++MARK <= SP) {
3899             register SV **svp;
3900             I32 elem = SvIV(*MARK);
3901
3902             if (elem > 0)
3903                 elem -= arybase;
3904             svp = av_fetch(av, elem, lval);
3905             if (lval) {
3906                 if (!svp || *svp == &PL_sv_undef)
3907                     DIE(aTHX_ PL_no_aelem, elem);
3908                 if (PL_op->op_private & OPpLVAL_INTRO)
3909                     save_aelem(av, elem, svp);
3910             }
3911             *MARK = svp ? *svp : &PL_sv_undef;
3912         }
3913     }
3914     if (GIMME != G_ARRAY) {
3915         MARK = ORIGMARK;
3916         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3917         SP = MARK;
3918     }
3919     RETURN;
3920 }
3921
3922 PP(pp_aeach)
3923 {
3924     dVAR;
3925     dSP;
3926     AV *array = (AV*)POPs;
3927     const I32 gimme = GIMME_V;
3928     IV *iterp = Perl_av_iter_p(aTHX_ array);
3929     const IV current = (*iterp)++;
3930
3931     if (current > av_len(array)) {
3932         *iterp = 0;
3933         if (gimme == G_SCALAR)
3934             RETPUSHUNDEF;
3935         else
3936             RETURN;
3937     }
3938
3939     EXTEND(SP, 2);
3940     mPUSHi(CopARYBASE_get(PL_curcop) + current);
3941     if (gimme == G_ARRAY) {
3942         SV **const element = av_fetch(array, current, 0);
3943         PUSHs(element ? *element : &PL_sv_undef);
3944     }
3945     RETURN;
3946 }
3947
3948 PP(pp_akeys)
3949 {
3950     dVAR;
3951     dSP;
3952     AV *array = (AV*)POPs;
3953     const I32 gimme = GIMME_V;
3954
3955     *Perl_av_iter_p(aTHX_ array) = 0;
3956
3957     if (gimme == G_SCALAR) {
3958         dTARGET;
3959         PUSHi(av_len(array) + 1);
3960     }
3961     else if (gimme == G_ARRAY) {
3962         IV n = Perl_av_len(aTHX_ array);
3963         IV i = CopARYBASE_get(PL_curcop);
3964
3965         EXTEND(SP, n + 1);
3966
3967         if (PL_op->op_type == OP_AKEYS) {
3968             n += i;
3969             for (;  i <= n;  i++) {
3970                 mPUSHi(i);
3971             }
3972         }
3973         else {
3974             for (i = 0;  i <= n;  i++) {
3975                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
3976                 PUSHs(elem ? *elem : &PL_sv_undef);
3977             }
3978         }
3979     }
3980     RETURN;
3981 }
3982
3983 /* Associative arrays. */
3984
3985 PP(pp_each)
3986 {
3987     dVAR;
3988     dSP;
3989     HV * hash = (HV*)POPs;
3990     HE *entry;
3991     const I32 gimme = GIMME_V;
3992
3993     PUTBACK;
3994     /* might clobber stack_sp */
3995     entry = hv_iternext(hash);
3996     SPAGAIN;
3997
3998     EXTEND(SP, 2);
3999     if (entry) {
4000         SV* const sv = hv_iterkeysv(entry);
4001         PUSHs(sv);      /* won't clobber stack_sp */
4002         if (gimme == G_ARRAY) {
4003             SV *val;
4004             PUTBACK;
4005             /* might clobber stack_sp */
4006             val = hv_iterval(hash, entry);
4007             SPAGAIN;
4008             PUSHs(val);
4009         }
4010     }
4011     else if (gimme == G_SCALAR)
4012         RETPUSHUNDEF;
4013
4014     RETURN;
4015 }
4016
4017 PP(pp_delete)
4018 {
4019     dVAR;
4020     dSP;
4021     const I32 gimme = GIMME_V;
4022     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4023
4024     if (PL_op->op_private & OPpSLICE) {
4025         dMARK; dORIGMARK;
4026         HV * const hv = (HV*)POPs;
4027         const U32 hvtype = SvTYPE(hv);
4028         if (hvtype == SVt_PVHV) {                       /* hash element */
4029             while (++MARK <= SP) {
4030                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4031                 *MARK = sv ? sv : &PL_sv_undef;
4032             }
4033         }
4034         else if (hvtype == SVt_PVAV) {                  /* array element */
4035             if (PL_op->op_flags & OPf_SPECIAL) {
4036                 while (++MARK <= SP) {
4037                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
4038                     *MARK = sv ? sv : &PL_sv_undef;
4039                 }
4040             }
4041         }
4042         else
4043             DIE(aTHX_ "Not a HASH reference");
4044         if (discard)
4045             SP = ORIGMARK;
4046         else if (gimme == G_SCALAR) {
4047             MARK = ORIGMARK;
4048             if (SP > MARK)
4049                 *++MARK = *SP;
4050             else
4051                 *++MARK = &PL_sv_undef;
4052             SP = MARK;
4053         }
4054     }
4055     else {
4056         SV *keysv = POPs;
4057         HV * const hv = (HV*)POPs;
4058         SV *sv;
4059         if (SvTYPE(hv) == SVt_PVHV)
4060             sv = hv_delete_ent(hv, keysv, discard, 0);
4061         else if (SvTYPE(hv) == SVt_PVAV) {
4062             if (PL_op->op_flags & OPf_SPECIAL)
4063                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
4064             else
4065                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4066         }
4067         else
4068             DIE(aTHX_ "Not a HASH reference");
4069         if (!sv)
4070             sv = &PL_sv_undef;
4071         if (!discard)
4072             PUSHs(sv);
4073     }
4074     RETURN;
4075 }
4076
4077 PP(pp_exists)
4078 {
4079     dVAR;
4080     dSP;
4081     SV *tmpsv;
4082     HV *hv;
4083
4084     if (PL_op->op_private & OPpEXISTS_SUB) {
4085         GV *gv;
4086         SV * const sv = POPs;
4087         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4088         if (cv)
4089             RETPUSHYES;
4090         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4091             RETPUSHYES;
4092         RETPUSHNO;
4093     }
4094     tmpsv = POPs;
4095     hv = (HV*)POPs;
4096     if (SvTYPE(hv) == SVt_PVHV) {
4097         if (hv_exists_ent(hv, tmpsv, 0))
4098             RETPUSHYES;
4099     }
4100     else if (SvTYPE(hv) == SVt_PVAV) {
4101         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4102             if (av_exists((AV*)hv, SvIV(tmpsv)))
4103                 RETPUSHYES;
4104         }
4105     }
4106     else {
4107         DIE(aTHX_ "Not a HASH reference");
4108     }
4109     RETPUSHNO;
4110 }
4111
4112 PP(pp_hslice)
4113 {
4114     dVAR; dSP; dMARK; dORIGMARK;
4115     register HV * const hv = (HV*)POPs;
4116     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4117     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4118     bool other_magic = FALSE;
4119
4120     if (localizing) {
4121         MAGIC *mg;
4122         HV *stash;
4123
4124         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4125             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4126              /* Try to preserve the existenceness of a tied hash
4127               * element by using EXISTS and DELETE if possible.
4128               * Fallback to FETCH and STORE otherwise */
4129              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4130              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4131              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4132     }
4133
4134     while (++MARK <= SP) {
4135         SV * const keysv = *MARK;
4136         SV **svp;
4137         HE *he;
4138         bool preeminent = FALSE;
4139
4140         if (localizing) {
4141             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4142                 hv_exists_ent(hv, keysv, 0);
4143         }
4144
4145         he = hv_fetch_ent(hv, keysv, lval, 0);
4146         svp = he ? &HeVAL(he) : NULL;
4147
4148         if (lval) {
4149             if (!svp || *svp == &PL_sv_undef) {
4150                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4151             }
4152             if (localizing) {
4153                 if (HvNAME_get(hv) && isGV(*svp))
4154                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4155                 else {
4156                     if (preeminent)
4157                         save_helem(hv, keysv, svp);
4158                     else {
4159                         STRLEN keylen;
4160                         const char * const key = SvPV_const(keysv, keylen);
4161                         SAVEDELETE(hv, savepvn(key,keylen),
4162                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4163                     }
4164                 }
4165             }
4166         }
4167         *MARK = svp ? *svp : &PL_sv_undef;
4168     }
4169     if (GIMME != G_ARRAY) {
4170         MARK = ORIGMARK;
4171         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4172         SP = MARK;
4173     }
4174     RETURN;
4175 }
4176
4177 /* List operators. */
4178
4179 PP(pp_list)
4180 {
4181     dVAR; dSP; dMARK;
4182     if (GIMME != G_ARRAY) {
4183         if (++MARK <= SP)
4184             *MARK = *SP;                /* unwanted list, return last item */
4185         else
4186             *MARK = &PL_sv_undef;
4187         SP = MARK;
4188     }
4189     RETURN;
4190 }
4191
4192 PP(pp_lslice)
4193 {
4194     dVAR;
4195     dSP;
4196     SV ** const lastrelem = PL_stack_sp;
4197     SV ** const lastlelem = PL_stack_base + POPMARK;
4198     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4199     register SV ** const firstrelem = lastlelem + 1;
4200     const I32 arybase = CopARYBASE_get(PL_curcop);
4201     I32 is_something_there = FALSE;
4202
4203     register const I32 max = lastrelem - lastlelem;
4204     register SV **lelem;
4205
4206     if (GIMME != G_ARRAY) {
4207         I32 ix = SvIV(*lastlelem);
4208         if (ix < 0)
4209             ix += max;
4210         else
4211             ix -= arybase;
4212         if (ix < 0 || ix >= max)
4213             *firstlelem = &PL_sv_undef;
4214         else
4215             *firstlelem = firstrelem[ix];
4216         SP = firstlelem;
4217         RETURN;
4218     }
4219
4220     if (max == 0) {
4221         SP = firstlelem - 1;
4222         RETURN;
4223     }
4224
4225     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4226         I32 ix = SvIV(*lelem);
4227         if (ix < 0)
4228             ix += max;
4229         else
4230             ix -= arybase;
4231         if (ix < 0 || ix >= max)
4232             *lelem = &PL_sv_undef;
4233         else {
4234             is_something_there = TRUE;
4235             if (!(*lelem = firstrelem[ix]))
4236                 *lelem = &PL_sv_undef;
4237         }
4238     }
4239     if (is_something_there)
4240         SP = lastlelem;
4241     else
4242         SP = firstlelem - 1;
4243     RETURN;
4244 }
4245
4246 PP(pp_anonlist)
4247 {
4248     dVAR; dSP; dMARK; dORIGMARK;
4249     const I32 items = SP - MARK;
4250     SV * const av = (SV *) av_make(items, MARK+1);
4251     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4252     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4253                       ? newRV_noinc(av) : av));
4254     RETURN;
4255 }
4256
4257 PP(pp_anonhash)
4258 {
4259     dVAR; dSP; dMARK; dORIGMARK;
4260     HV* const hv = newHV();
4261
4262     while (MARK < SP) {
4263         SV * const key = *++MARK;
4264         SV * const val = newSV(0);
4265         if (MARK < SP)
4266             sv_setsv(val, *++MARK);
4267         else if (ckWARN(WARN_MISC))
4268             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4269         (void)hv_store_ent(hv,key,val,0);
4270     }
4271     SP = ORIGMARK;
4272     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4273                       ? newRV_noinc((SV*) hv) : (SV*)hv));
4274     RETURN;
4275 }
4276
4277 PP(pp_splice)
4278 {
4279     dVAR; dSP; dMARK; dORIGMARK;
4280     register AV *ary = (AV*)*++MARK;
4281     register SV **src;
4282     register SV **dst;
4283     register I32 i;
4284     register I32 offset;
4285     register I32 length;
4286     I32 newlen;
4287     I32 after;
4288     I32 diff;
4289     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4290
4291     if (mg) {
4292         *MARK-- = SvTIED_obj((SV*)ary, mg);
4293         PUSHMARK(MARK);
4294         PUTBACK;
4295         ENTER;
4296         call_method("SPLICE",GIMME_V);
4297         LEAVE;
4298         SPAGAIN;
4299         RETURN;
4300     }
4301
4302     SP++;
4303
4304     if (++MARK < SP) {
4305         offset = i = SvIV(*MARK);
4306         if (offset < 0)
4307             offset += AvFILLp(ary) + 1;
4308         else
4309             offset -= CopARYBASE_get(PL_curcop);
4310         if (offset < 0)
4311             DIE(aTHX_ PL_no_aelem, i);
4312         if (++MARK < SP) {
4313             length = SvIVx(*MARK++);
4314             if (length < 0) {
4315                 length += AvFILLp(ary) - offset + 1;
4316                 if (length < 0)
4317                     length = 0;
4318             }
4319         }
4320         else
4321             length = AvMAX(ary) + 1;            /* close enough to infinity */
4322     }
4323     else {
4324         offset = 0;
4325         length = AvMAX(ary) + 1;
4326     }
4327     if (offset > AvFILLp(ary) + 1) {
4328         if (ckWARN(WARN_MISC))
4329             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4330         offset = AvFILLp(ary) + 1;
4331     }
4332     after = AvFILLp(ary) + 1 - (offset + length);
4333     if (after < 0) {                            /* not that much array */
4334         length += after;                        /* offset+length now in array */
4335         after = 0;
4336         if (!AvALLOC(ary))
4337             av_extend(ary, 0);
4338     }
4339
4340     /* At this point, MARK .. SP-1 is our new LIST */
4341
4342     newlen = SP - MARK;
4343     diff = newlen - length;
4344     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4345         av_reify(ary);
4346
4347     /* make new elements SVs now: avoid problems if they're from the array */
4348     for (dst = MARK, i = newlen; i; i--) {
4349         SV * const h = *dst;
4350         *dst++ = newSVsv(h);
4351     }
4352
4353     if (diff < 0) {                             /* shrinking the area */
4354         SV **tmparyval = NULL;
4355         if (newlen) {
4356             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4357             Copy(MARK, tmparyval, newlen, SV*);
4358         }
4359
4360         MARK = ORIGMARK + 1;
4361         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4362             MEXTEND(MARK, length);
4363             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4364             if (AvREAL(ary)) {
4365                 EXTEND_MORTAL(length);
4366                 for (i = length, dst = MARK; i; i--) {
4367                     sv_2mortal(*dst);   /* free them eventualy */
4368                     dst++;
4369                 }
4370             }
4371             MARK += length - 1;
4372         }
4373         else {
4374             *MARK = AvARRAY(ary)[offset+length-1];
4375             if (AvREAL(ary)) {
4376                 sv_2mortal(*MARK);
4377                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4378                     SvREFCNT_dec(*dst++);       /* free them now */
4379             }
4380         }
4381         AvFILLp(ary) += diff;
4382
4383         /* pull up or down? */
4384
4385         if (offset < after) {                   /* easier to pull up */
4386             if (offset) {                       /* esp. if nothing to pull */
4387                 src = &AvARRAY(ary)[offset-1];
4388                 dst = src - diff;               /* diff is negative */
4389                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4390                     *dst-- = *src--;
4391             }
4392             dst = AvARRAY(ary);
4393             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4394             AvMAX(ary) += diff;
4395         }
4396         else {
4397             if (after) {                        /* anything to pull down? */
4398                 src = AvARRAY(ary) + offset + length;
4399                 dst = src + diff;               /* diff is negative */
4400                 Move(src, dst, after, SV*);
4401             }
4402             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4403                                                 /* avoid later double free */
4404         }
4405         i = -diff;
4406         while (i)
4407             dst[--i] = &PL_sv_undef;
4408
4409         if (newlen) {
4410             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4411             Safefree(tmparyval);
4412         }
4413     }
4414     else {                                      /* no, expanding (or same) */
4415         SV** tmparyval = NULL;
4416         if (length) {
4417             Newx(tmparyval, length, SV*);       /* so remember deletion */
4418             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4419         }
4420
4421         if (diff > 0) {                         /* expanding */
4422             /* push up or down? */
4423             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4424                 if (offset) {
4425                     src = AvARRAY(ary);
4426                     dst = src - diff;
4427                     Move(src, dst, offset, SV*);
4428                 }
4429                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4430                 AvMAX(ary) += diff;
4431                 AvFILLp(ary) += diff;
4432             }
4433             else {
4434                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4435                     av_extend(ary, AvFILLp(ary) + diff);
4436                 AvFILLp(ary) += diff;
4437
4438                 if (after) {
4439                     dst = AvARRAY(ary) + AvFILLp(ary);
4440                     src = dst - diff;
4441                     for (i = after; i; i--) {
4442                         *dst-- = *src--;
4443                     }
4444                 }
4445             }
4446         }
4447
4448         if (newlen) {
4449             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4450         }
4451
4452         MARK = ORIGMARK + 1;
4453         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4454             if (length) {
4455                 Copy(tmparyval, MARK, length, SV*);
4456                 if (AvREAL(ary)) {
4457                     EXTEND_MORTAL(length);
4458                     for (i = length, dst = MARK; i; i--) {
4459                         sv_2mortal(*dst);       /* free them eventualy */
4460                         dst++;
4461                     }
4462                 }
4463             }
4464             MARK += length - 1;
4465         }
4466         else if (length--) {
4467             *MARK = tmparyval[length];
4468             if (AvREAL(ary)) {
4469                 sv_2mortal(*MARK);
4470                 while (length-- > 0)
4471                     SvREFCNT_dec(tmparyval[length]);
4472             }
4473         }
4474         else
4475             *MARK = &PL_sv_undef;
4476         Safefree(tmparyval);
4477     }
4478     SP = MARK;
4479     RETURN;
4480 }
4481
4482 PP(pp_push)
4483 {
4484     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4485     register AV * const ary = (AV*)*++MARK;
4486     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4487
4488     if (mg) {
4489         *MARK-- = SvTIED_obj((SV*)ary, mg);
4490         PUSHMARK(MARK);
4491         PUTBACK;
4492         ENTER;
4493         call_method("PUSH",G_SCALAR|G_DISCARD);
4494         LEAVE;
4495         SPAGAIN;
4496         SP = ORIGMARK;
4497         PUSHi( AvFILL(ary) + 1 );
4498     }
4499     else {
4500         PL_delaymagic = DM_DELAY;
4501         for (++MARK; MARK <= SP; MARK++) {
4502             SV * const sv = newSV(0);
4503             if (*MARK)
4504                 sv_setsv(sv, *MARK);
4505             av_store(ary, AvFILLp(ary)+1, sv);
4506         }
4507         if (PL_delaymagic & DM_ARRAY)
4508             mg_set((SV*)ary);
4509
4510         PL_delaymagic = 0;
4511         SP = ORIGMARK;
4512         PUSHi( AvFILLp(ary) + 1 );
4513     }
4514     RETURN;
4515 }
4516
4517 PP(pp_shift)
4518 {
4519     dVAR;
4520     dSP;
4521     AV * const av = (AV*)POPs;
4522     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4523     EXTEND(SP, 1);
4524     assert (sv);
4525     if (AvREAL(av))
4526         (void)sv_2mortal(sv);
4527     PUSHs(sv);
4528     RETURN;
4529 }
4530
4531 PP(pp_unshift)
4532 {
4533     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4534     register AV *ary = (AV*)*++MARK;
4535     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4536
4537     if (mg) {
4538         *MARK-- = SvTIED_obj((SV*)ary, mg);
4539         PUSHMARK(MARK);
4540         PUTBACK;
4541         ENTER;
4542         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4543         LEAVE;
4544         SPAGAIN;
4545     }
4546     else {
4547         register I32 i = 0;
4548         av_unshift(ary, SP - MARK);
4549         while (MARK < SP) {
4550             SV * const sv = newSVsv(*++MARK);
4551             (void)av_store(ary, i++, sv);
4552         }
4553     }
4554     SP = ORIGMARK;
4555     PUSHi( AvFILL(ary) + 1 );
4556     RETURN;
4557 }
4558
4559 PP(pp_reverse)
4560 {
4561     dVAR; dSP; dMARK;
4562     SV ** const oldsp = SP;
4563
4564     if (GIMME == G_ARRAY) {
4565         MARK++;
4566         while (MARK < SP) {
4567             register SV * const tmp = *MARK;
4568             *MARK++ = *SP;
4569             *SP-- = tmp;
4570         }
4571         /* safe as long as stack cannot get extended in the above */
4572         SP = oldsp;
4573     }
4574     else {
4575         register char *up;
4576         register char *down;
4577         register I32 tmp;
4578         dTARGET;
4579         STRLEN len;
4580         PADOFFSET padoff_du;
4581
4582         SvUTF8_off(TARG);                               /* decontaminate */
4583         if (SP - MARK > 1)
4584             do_join(TARG, &PL_sv_no, MARK, SP);
4585         else
4586             sv_setsv(TARG, (SP > MARK)
4587                     ? *SP
4588                     : (padoff_du = find_rundefsvoffset(),
4589                         (padoff_du == NOT_IN_PAD
4590                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4591                         ? DEFSV : PAD_SVl(padoff_du)));
4592         up = SvPV_force(TARG, len);
4593         if (len > 1) {
4594             if (DO_UTF8(TARG)) {        /* first reverse each character */
4595                 U8* s = (U8*)SvPVX(TARG);
4596                 const U8* send = (U8*)(s + len);
4597                 while (s < send) {
4598                     if (UTF8_IS_INVARIANT(*s)) {
4599                         s++;
4600                         continue;
4601                     }
4602                     else {
4603                         if (!utf8_to_uvchr(s, 0))
4604                             break;
4605                         up = (char*)s;
4606                         s += UTF8SKIP(s);
4607                         down = (char*)(s - 1);
4608                         /* reverse this character */
4609                         while (down > up) {
4610                             tmp = *up;
4611                             *up++ = *down;
4612                             *down-- = (char)tmp;
4613                         }
4614                     }
4615                 }
4616                 up = SvPVX(TARG);
4617             }
4618             down = SvPVX(TARG) + len - 1;
4619             while (down > up) {
4620                 tmp = *up;
4621                 *up++ = *down;
4622                 *down-- = (char)tmp;
4623             }
4624             (void)SvPOK_only_UTF8(TARG);
4625         }
4626         SP = MARK + 1;
4627         SETTARG;
4628     }
4629     RETURN;
4630 }
4631
4632 PP(pp_split)
4633 {
4634     dVAR; dSP; dTARG;
4635     AV *ary;
4636     register IV limit = POPi;                   /* note, negative is forever */
4637     SV * const sv = POPs;
4638     STRLEN len;
4639     register const char *s = SvPV_const(sv, len);
4640     const bool do_utf8 = DO_UTF8(sv);
4641     const char *strend = s + len;
4642     register PMOP *pm;
4643     register REGEXP *rx;
4644     register SV *dstr;
4645     register const char *m;
4646     I32 iters = 0;
4647     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4648     I32 maxiters = slen + 10;
4649     const char *orig;
4650     const I32 origlimit = limit;
4651     I32 realarray = 0;
4652     I32 base;
4653     const I32 gimme = GIMME_V;
4654     const I32 oldsave = PL_savestack_ix;
4655     I32 make_mortal = 1;
4656     bool multiline = 0;
4657     MAGIC *mg = NULL;
4658
4659 #ifdef DEBUGGING
4660     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4661 #else
4662     pm = (PMOP*)POPs;
4663 #endif
4664     if (!pm || !s)
4665         DIE(aTHX_ "panic: pp_split");
4666     rx = PM_GETRE(pm);
4667
4668     TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4669              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4670
4671     RX_MATCH_UTF8_set(rx, do_utf8);
4672
4673 #ifdef USE_ITHREADS
4674     if (pm->op_pmreplrootu.op_pmtargetoff) {
4675         ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4676     }
4677 #else
4678     if (pm->op_pmreplrootu.op_pmtargetgv) {
4679         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4680     }
4681 #endif
4682     else if (gimme != G_ARRAY)
4683         ary = GvAVn(PL_defgv);
4684     else
4685         ary = NULL;
4686     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4687         realarray = 1;
4688         PUTBACK;
4689         av_extend(ary,0);
4690         av_clear(ary);
4691         SPAGAIN;
4692         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4693             PUSHMARK(SP);
4694             XPUSHs(SvTIED_obj((SV*)ary, mg));
4695         }
4696         else {
4697             if (!AvREAL(ary)) {
4698                 I32 i;
4699                 AvREAL_on(ary);
4700                 AvREIFY_off(ary);
4701                 for (i = AvFILLp(ary); i >= 0; i--)
4702                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4703             }
4704             /* temporarily switch stacks */
4705             SAVESWITCHSTACK(PL_curstack, ary);
4706             make_mortal = 0;
4707         }
4708     }
4709     base = SP - PL_stack_base;
4710     orig = s;
4711     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4712         if (do_utf8) {
4713             while (*s == ' ' || is_utf8_space((U8*)s))
4714                 s += UTF8SKIP(s);
4715         }
4716         else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4717             while (isSPACE_LC(*s))
4718                 s++;
4719         }
4720         else {
4721             while (isSPACE(*s))
4722                 s++;
4723         }
4724     }
4725     if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4726         multiline = 1;
4727     }
4728
4729     if (!limit)
4730         limit = maxiters + 2;
4731     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4732         while (--limit) {
4733             m = s;
4734             /* this one uses 'm' and is a negative test */
4735             if (do_utf8) {
4736                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4737                     const int t = UTF8SKIP(m);
4738                     /* is_utf8_space returns FALSE for malform utf8 */
4739                     if (strend - m < t)
4740                         m = strend;
4741                     else
4742                         m += t;
4743                 }
4744             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4745                 while (m < strend && !isSPACE_LC(*m))
4746                     ++m;
4747             } else {
4748                 while (m < strend && !isSPACE(*m))
4749                     ++m;
4750             }
4751             if (m >= strend)
4752                 break;
4753
4754             dstr = newSVpvn_utf8(s, m-s, do_utf8);
4755             if (make_mortal)
4756                 sv_2mortal(dstr);
4757             XPUSHs(dstr);
4758
4759             /* skip the whitespace found last */
4760             if (do_utf8)
4761                 s = m + UTF8SKIP(m);
4762             else
4763                 s = m + 1;
4764
4765             /* this one uses 's' and is a positive test */
4766             if (do_utf8) {
4767                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4768                     s +=  UTF8SKIP(s);
4769             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4770                 while (s < strend && isSPACE_LC(*s))
4771                     ++s;
4772             } else {
4773                 while (s < strend && isSPACE(*s))
4774                     ++s;
4775             }
4776         }
4777     }
4778     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4779         while (--limit) {
4780             for (m = s; m < strend && *m != '\n'; m++)
4781                 ;
4782             m++;
4783             if (m >= strend)
4784                 break;
4785             dstr = newSVpvn_utf8(s, m-s, do_utf8);
4786             if (make_mortal)
4787                 sv_2mortal(dstr);
4788             XPUSHs(dstr);
4789             s = m;
4790         }
4791     }
4792     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4793         /*
4794           Pre-extend the stack, either the number of bytes or
4795           characters in the string or a limited amount, triggered by:
4796
4797           my ($x, $y) = split //, $str;
4798             or
4799           split //, $str, $i;
4800         */
4801         const U32 items = limit - 1;
4802         if (items < slen)
4803             EXTEND(SP, items);
4804         else
4805             EXTEND(SP, slen);
4806
4807         if (do_utf8) {
4808             while (--limit) {
4809                 /* keep track of how many bytes we skip over */
4810                 m = s;
4811                 s += UTF8SKIP(s);
4812                 dstr = newSVpvn_utf8(m, s-m, TRUE);
4813
4814                 if (make_mortal)
4815                     sv_2mortal(dstr);
4816
4817                 PUSHs(dstr);
4818
4819                 if (s >= strend)
4820                     break;
4821             }
4822         } else {
4823             while (--limit) {
4824                 dstr = newSVpvn(s, 1);
4825
4826                 s++;
4827
4828                 if (make_mortal)
4829                     sv_2mortal(dstr);
4830
4831                 PUSHs(dstr);
4832
4833                 if (s >= strend)
4834                     break;
4835             }
4836         }
4837     }
4838     else if (do_utf8 == ((RX_EXTFLAGS(rx) & RXf_UTF8) != 0) &&
4839              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4840              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4841              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4842         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4843         SV * const csv = CALLREG_INTUIT_STRING(rx);
4844
4845         len = RX_MINLENRET(rx);
4846         if (len == 1 && !(RX_EXTFLAGS(rx) & RXf_UTF8) && !tail) {
4847             const char c = *SvPV_nolen_const(csv);
4848             while (--limit) {
4849                 for (m = s; m < strend && *m != c; m++)
4850                     ;
4851                 if (m >= strend)
4852                     break;
4853                 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4854                 if (make_mortal)
4855                     sv_2mortal(dstr);
4856                 XPUSHs(dstr);
4857                 /* The rx->minlen is in characters but we want to step
4858                  * s ahead by bytes. */
4859                 if (do_utf8)
4860                     s = (char*)utf8_hop((U8*)m, len);
4861                 else
4862                     s = m + len; /* Fake \n at the end */
4863             }
4864         }
4865         else {
4866             while (s < strend && --limit &&
4867               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4868                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4869             {
4870                 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4871                 if (make_mortal)
4872                     sv_2mortal(dstr);
4873                 XPUSHs(dstr);
4874                 /* The rx->minlen is in characters but we want to step
4875                  * s ahead by bytes. */
4876                 if (do_utf8)
4877                     s = (char*)utf8_hop((U8*)m, len);
4878                 else
4879                     s = m + len; /* Fake \n at the end */
4880             }
4881         }
4882     }
4883     else {
4884         maxiters += slen * RX_NPARENS(rx);
4885         while (s < strend && --limit)
4886         {
4887             I32 rex_return;
4888             PUTBACK;
4889             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4890                             sv, NULL, 0);
4891             SPAGAIN;
4892             if (rex_return == 0)
4893                 break;
4894             TAINT_IF(RX_MATCH_TAINTED(rx));
4895             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4896                 m = s;
4897                 s = orig;
4898                 orig = RX_SUBBEG(rx);
4899                 s = orig + (m - s);
4900                 strend = s + (strend - m);
4901             }
4902             m = RX_OFFS(rx)[0].start + orig;
4903             dstr = newSVpvn_utf8(s, m-s, do_utf8);
4904             if (make_mortal)
4905                 sv_2mortal(dstr);
4906             XPUSHs(dstr);
4907             if (RX_NPARENS(rx)) {
4908                 I32 i;
4909                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4910                     s = RX_OFFS(rx)[i].start + orig;
4911                     m = RX_OFFS(rx)[i].end + orig;
4912
4913                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4914                        parens that didn't match -- they should be set to
4915                        undef, not the empty string */
4916                     if (m >= orig && s >= orig) {
4917                         dstr = newSVpvn_utf8(s, m-s, do_utf8);
4918                     }
4919                     else
4920                         dstr = &PL_sv_undef;  /* undef, not "" */
4921                     if (make_mortal)
4922                         sv_2mortal(dstr);
4923                     XPUSHs(dstr);
4924                 }
4925             }
4926             s = RX_OFFS(rx)[0].end + orig;
4927         }
4928     }
4929
4930     iters = (SP - PL_stack_base) - base;
4931     if (iters > maxiters)
4932         DIE(aTHX_ "Split loop");
4933
4934     /* keep field after final delim? */
4935     if (s < strend || (iters && origlimit)) {
4936         const STRLEN l = strend - s;
4937         dstr = newSVpvn_utf8(s, l, do_utf8);
4938         if (make_mortal)
4939             sv_2mortal(dstr);
4940         XPUSHs(dstr);
4941         iters++;
4942     }
4943     else if (!origlimit) {
4944         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4945             if (TOPs && !make_mortal)
4946                 sv_2mortal(TOPs);
4947             iters--;
4948             *SP-- = &PL_sv_undef;
4949         }
4950     }
4951
4952     PUTBACK;
4953     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4954     SPAGAIN;
4955     if (realarray) {
4956         if (!mg) {
4957             if (SvSMAGICAL(ary)) {
4958                 PUTBACK;
4959                 mg_set((SV*)ary);
4960                 SPAGAIN;
4961             }
4962             if (gimme == G_ARRAY) {
4963                 EXTEND(SP, iters);
4964                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4965                 SP += iters;
4966                 RETURN;
4967             }
4968         }
4969         else {
4970             PUTBACK;
4971             ENTER;
4972             call_method("PUSH",G_SCALAR|G_DISCARD);
4973             LEAVE;
4974             SPAGAIN;
4975             if (gimme == G_ARRAY) {
4976                 I32 i;
4977                 /* EXTEND should not be needed - we just popped them */
4978                 EXTEND(SP, iters);
4979                 for (i=0; i < iters; i++) {
4980                     SV **svp = av_fetch(ary, i, FALSE);
4981                     PUSHs((svp) ? *svp : &PL_sv_undef);
4982                 }
4983                 RETURN;
4984             }
4985         }
4986     }
4987     else {
4988         if (gimme == G_ARRAY)
4989             RETURN;
4990     }
4991
4992     GETTARGET;
4993     PUSHi(iters);
4994     RETURN;
4995 }
4996
4997 PP(pp_once)
4998 {
4999     dSP;
5000     SV *const sv = PAD_SVl(PL_op->op_targ);
5001
5002     if (SvPADSTALE(sv)) {
5003         /* First time. */
5004         SvPADSTALE_off(sv);
5005         RETURNOP(cLOGOP->op_other);
5006     }
5007     RETURNOP(cLOGOP->op_next);
5008 }
5009
5010 PP(pp_lock)
5011 {
5012     dVAR;
5013     dSP;
5014     dTOPss;
5015     SV *retsv = sv;
5016     SvLOCK(sv);
5017     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5018         || SvTYPE(retsv) == SVt_PVCV) {
5019         retsv = refto(retsv);
5020     }
5021     SETs(retsv);
5022     RETURN;
5023 }
5024
5025
5026 PP(unimplemented_op)
5027 {
5028     dVAR;
5029     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5030         PL_op->op_type);
5031 }
5032
5033 /*
5034  * Local variables:
5035  * c-indentation-style: bsd
5036  * c-basic-offset: 4
5037  * indent-tabs-mode: t
5038  * End:
5039  *
5040  * ex: set ts=8 sts=4 sw=4 noet:
5041  */