pp.c

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