pp.c

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