pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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
  13  *  to discover, and no knowing what you'll find round a corner.
  14  *  And Elves, sir!'                            --Samwise Gamgee
  15  *
  16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
  17  */
  18
  19 /* This file contains general pp ("push/pop") functions that execute the
  20  * opcodes that make up a perl program. A typical pp function expects to
  21  * find its arguments on the stack, and usually pushes its results onto
  22  * the stack, hence the 'pp' terminology. Each OP structure contains
  23  * a pointer to the relevant pp_foo() function.
  24  */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_PP_C
  28 #include "perl.h"
  29 #include "keywords.h"
  30
  31 #include "reentr.h"
  32
  33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  34    it, since pid_t is an integral type.
  35    --AD  2/20/1998
  36 */
  37 #ifdef NEED_GETPID_PROTO
  38 extern Pid_t getpid (void);
  39 #endif
  40
  41 /*
  42  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
  43  * This switches them over to IEEE.
  44  */
  45 #if defined(LIBM_LIB_VERSION)
  46     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
  47 #endif
  48
  49 /* variations on pp_null */
  50
  51 PP(pp_stub)
  52 {
  53     dVAR;
  54     dSP;
  55     if (GIMME_V == G_SCALAR)
  56         XPUSHs(&PL_sv_undef);
  57     RETURN;
  58 }
  59
  60 /* Pushy stuff. */
  61
  62 PP(pp_padav)
  63 {
  64     dVAR; dSP; dTARGET;
  65     I32 gimme;
  66     assert(SvTYPE(TARG) == SVt_PVAV);
  67     if (PL_op->op_private & OPpLVAL_INTRO)
  68         if (!(PL_op->op_private & OPpPAD_STATE))
  69             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  70     EXTEND(SP, 1);
  71     if (PL_op->op_flags & OPf_REF) {
  72         PUSHs(TARG);
  73         RETURN;
  74     } else if (LVRET) {
  75         if (GIMME == G_SCALAR)
  76             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  77         PUSHs(TARG);
  78         RETURN;
  79     }
  80     gimme = GIMME_V;
  81     if (gimme == G_ARRAY) {
  82         const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
  83         EXTEND(SP, maxarg);
  84         if (SvMAGICAL(TARG)) {
  85             U32 i;
  86             for (i=0; i < (U32)maxarg; i++) {
  87                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
  88                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  89             }
  90         }
  91         else {
  92             Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
  93         }
  94         SP += maxarg;
  95     }
  96     else if (gimme == G_SCALAR) {
  97         SV* const sv = sv_newmortal();
  98         const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
  99         sv_setiv(sv, maxarg);
 100         PUSHs(sv);
 101     }
 102     RETURN;
 103 }
 104
 105 PP(pp_padhv)
 106 {
 107     dVAR; dSP; dTARGET;
 108     I32 gimme;
 109
 110     assert(SvTYPE(TARG) == SVt_PVHV);
 111     XPUSHs(TARG);
 112     if (PL_op->op_private & OPpLVAL_INTRO)
 113         if (!(PL_op->op_private & OPpPAD_STATE))
 114             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 115     if (PL_op->op_flags & OPf_REF)
 116         RETURN;
 117     else if (LVRET) {
 118         if (GIMME == G_SCALAR)
 119             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 120         RETURN;
 121     }
 122     gimme = GIMME_V;
 123     if (gimme == G_ARRAY) {
 124         RETURNOP(do_kv());
 125     }
 126     else if (gimme == G_SCALAR) {
 127         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
 128         SETs(sv);
 129     }
 130     RETURN;
 131 }
 132
 133 /* Translations. */
 134
 135 static const char S_no_symref_sv[] =
 136     "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
 137
 138 PP(pp_rv2gv)
 139 {
 140     dVAR; dSP; dTOPss;
 141
 142     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
 143     if (SvROK(sv)) {
 144       wasref:
 145         sv = amagic_deref_call(sv, to_gv_amg);
 146         SPAGAIN;
 147
 148         sv = SvRV(sv);
 149         if (SvTYPE(sv) == SVt_PVIO) {
 150             GV * const gv = MUTABLE_GV(sv_newmortal());
 151             gv_init(gv, 0, "", 0, 0);
 152             GvIOp(gv) = MUTABLE_IO(sv);
 153             SvREFCNT_inc_void_NN(sv);
 154             sv = MUTABLE_SV(gv);
 155         }
 156         else if (!isGV_with_GP(sv))
 157             DIE(aTHX_ "Not a GLOB reference");
 158     }
 159     else {
 160         if (!isGV_with_GP(sv)) {
 161             if (!SvOK(sv) && sv != &PL_sv_undef) {
 162                 /* If this is a 'my' scalar and flag is set then vivify
 163                  * NI-S 1999/05/07
 164                  */
 165                 if (SvREADONLY(sv))
 166                     Perl_croak_no_modify(aTHX);
 167                 if (PL_op->op_private & OPpDEREF) {
 168                     GV *gv;
 169                     if (cUNOP->op_targ) {
 170                         STRLEN len;
 171                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 172                         const char * const name = SvPV(namesv, len);
 173                         gv = MUTABLE_GV(newSV(0));
 174                         gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
 175                     }
 176                     else {
 177                         const char * const name = CopSTASHPV(PL_curcop);
 178                         gv = newGVgen(name);
 179                     }
 180                     prepare_SV_for_RV(sv);
 181                     SvRV_set(sv, MUTABLE_SV(gv));
 182                     SvROK_on(sv);
 183                     SvSETMAGIC(sv);
 184                     goto wasref;
 185                 }
 186                 if (PL_op->op_flags & OPf_REF ||
 187                     PL_op->op_private & HINT_STRICT_REFS)
 188                     DIE(aTHX_ PL_no_usym, "a symbol");
 189                 if (ckWARN(WARN_UNINITIALIZED))
 190                     report_uninit(sv);
 191                 RETSETUNDEF;
 192             }
 193             if ((PL_op->op_flags & OPf_SPECIAL) &&
 194                 !(PL_op->op_flags & OPf_MOD))
 195             {
 196                 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
 197                 if (!temp
 198                     && (!is_gv_magical_sv(sv,0)
 199                         || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
 200                                                         SVt_PVGV))))) {
 201                     RETSETUNDEF;
 202                 }
 203                 sv = temp;
 204             }
 205             else {
 206                 if (PL_op->op_private & HINT_STRICT_REFS)
 207                     DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
 208                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 209                     == OPpDONT_INIT_GV) {
 210                     /* We are the target of a coderef assignment.  Return
 211                        the scalar unchanged, and let pp_sasssign deal with
 212                        things.  */
 213                     RETURN;
 214                 }
 215                 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
 216             }
 217             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 218             if (sv) SvFAKE_off(sv);
 219         }
 220     }
 221     if (PL_op->op_private & OPpLVAL_INTRO)
 222         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 223     if (sv && SvFAKE(sv)) {
 224         SV *newsv = sv_newmortal();
 225         sv_setsv_flags(newsv, sv, 0);
 226         SvFAKE_off(newsv);
 227         SETs(newsv);
 228     }
 229     else SETs(sv);
 230     RETURN;
 231 }
 232
 233 /* Helper function for pp_rv2sv and pp_rv2av  */
 234 GV *
 235 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 236                 const svtype type, SV ***spp)
 237 {
 238     dVAR;
 239     GV *gv;
 240
 241     PERL_ARGS_ASSERT_SOFTREF2XV;
 242
 243     if (PL_op->op_private & HINT_STRICT_REFS) {
 244         if (SvOK(sv))
 245             Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 246         else
 247             Perl_die(aTHX_ PL_no_usym, what);
 248     }
 249     if (!SvOK(sv)) {
 250         if (PL_op->op_flags & OPf_REF)
 251             Perl_die(aTHX_ PL_no_usym, what);
 252         if (ckWARN(WARN_UNINITIALIZED))
 253             report_uninit(sv);
 254         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 255             (*spp)--;
 256             return NULL;
 257         }
 258         **spp = &PL_sv_undef;
 259         return NULL;
 260     }
 261     if ((PL_op->op_flags & OPf_SPECIAL) &&
 262         !(PL_op->op_flags & OPf_MOD))
 263         {
 264             gv = gv_fetchsv(sv, 0, type);
 265             if (!gv
 266                 && (!is_gv_magical_sv(sv,0)
 267                     || !(gv = gv_fetchsv(sv, GV_ADD, type))))
 268                 {
 269                     **spp = &PL_sv_undef;
 270                     return NULL;
 271                 }
 272         }
 273     else {
 274         gv = gv_fetchsv(sv, GV_ADD, type);
 275     }
 276     return gv;
 277 }
 278
 279 PP(pp_rv2sv)
 280 {
 281     dVAR; dSP; dTOPss;
 282     GV *gv = NULL;
 283
 284     if (!(PL_op->op_private & OPpDEREFed))
 285         SvGETMAGIC(sv);
 286     if (SvROK(sv)) {
 287         sv = amagic_deref_call(sv, to_sv_amg);
 288         SPAGAIN;
 289
 290         sv = SvRV(sv);
 291         switch (SvTYPE(sv)) {
 292         case SVt_PVAV:
 293         case SVt_PVHV:
 294         case SVt_PVCV:
 295         case SVt_PVFM:
 296         case SVt_PVIO:
 297             DIE(aTHX_ "Not a SCALAR reference");
 298         default: NOOP;
 299         }
 300     }
 301     else {
 302         gv = MUTABLE_GV(sv);
 303
 304         if (!isGV_with_GP(gv)) {
 305             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 306             if (!gv)
 307                 RETURN;
 308         }
 309         sv = GvSVn(gv);
 310     }
 311     if (PL_op->op_flags & OPf_MOD) {
 312         if (PL_op->op_private & OPpLVAL_INTRO) {
 313             if (cUNOP->op_first->op_type == OP_NULL)
 314                 sv = save_scalar(MUTABLE_GV(TOPs));
 315             else if (gv)
 316                 sv = save_scalar(gv);
 317             else
 318                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 319         }
 320         else if (PL_op->op_private & OPpDEREF)
 321             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 322     }
 323     SETs(sv);
 324     RETURN;
 325 }
 326
 327 PP(pp_av2arylen)
 328 {
 329     dVAR; dSP;
 330     AV * const av = MUTABLE_AV(TOPs);
 331     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 332     if (lvalue) {
 333         SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 334         if (!*sv) {
 335             *sv = newSV_type(SVt_PVMG);
 336             sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 337         }
 338         SETs(*sv);
 339     } else {
 340         SETs(sv_2mortal(newSViv(
 341             AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
 342         )));
 343     }
 344     RETURN;
 345 }
 346
 347 PP(pp_pos)
 348 {
 349     dVAR; dSP; dPOPss;
 350
 351     if (PL_op->op_flags & OPf_MOD || LVRET) {
 352         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
 353         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 354         LvTYPE(ret) = '.';
 355         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 356         PUSHs(ret);    /* no SvSETMAGIC */
 357         RETURN;
 358     }
 359     else {
 360         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 361             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
 362             if (mg && mg->mg_len >= 0) {
 363                 dTARGET;
 364                 I32 i = mg->mg_len;
 365                 if (DO_UTF8(sv))
 366                     sv_pos_b2u(sv, &i);
 367                 PUSHi(i + CopARYBASE_get(PL_curcop));
 368                 RETURN;
 369             }
 370         }
 371         RETPUSHUNDEF;
 372     }
 373 }
 374
 375 PP(pp_rv2cv)
 376 {
 377     dVAR; dSP;
 378     GV *gv;
 379     HV *stash_unused;
 380     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 381         ? 0
 382         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
 383             ? GV_ADD|GV_NOEXPAND
 384             : GV_ADD;
 385     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 386     /* (But not in defined().) */
 387
 388     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 389     if (cv) {
 390         if (CvCLONE(cv))
 391             cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 392         if ((PL_op->op_private & OPpLVAL_INTRO)) {
 393             if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
 394                 cv = GvCV(gv);
 395             if (!CvLVALUE(cv))
 396                 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
 397         }
 398     }
 399     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 400         cv = MUTABLE_CV(gv);
 401     }
 402     else
 403         cv = MUTABLE_CV(&PL_sv_undef);
 404     SETs(MUTABLE_SV(cv));
 405     RETURN;
 406 }
 407
 408 PP(pp_prototype)
 409 {
 410     dVAR; dSP;
 411     CV *cv;
 412     HV *stash;
 413     GV *gv;
 414     SV *ret = &PL_sv_undef;
 415
 416     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 417         const char * s = SvPVX_const(TOPs);
 418         if (strnEQ(s, "CORE::", 6)) {
 419             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 420             if (code < 0) {     /* Overridable. */
 421 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 422                 int i = 0, n = 0, seen_question = 0, defgv = 0;
 423                 I32 oa;
 424                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 425
 426                 if (code == -KEY_chop || code == -KEY_chomp
 427                         || code == -KEY_exec || code == -KEY_system)
 428                     goto set;
 429                 if (code == -KEY_mkdir) {
 430                     ret = newSVpvs_flags("_;$", SVs_TEMP);
 431                     goto set;
 432                 }
 433                 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
 434                     ret = newSVpvs_flags("+", SVs_TEMP);
 435                     goto set;
 436                 }
 437                 if (code == -KEY_push || code == -KEY_unshift) {
 438                     ret = newSVpvs_flags("+@", SVs_TEMP);
 439                     goto set;
 440                 }
 441                 if (code == -KEY_pop || code == -KEY_shift) {
 442                     ret = newSVpvs_flags(";+", SVs_TEMP);
 443                     goto set;
 444                 }
 445                 if (code == -KEY_splice) {
 446                     ret = newSVpvs_flags("+;$$@", SVs_TEMP);
 447                     goto set;
 448                 }
 449                 if (code == -KEY_tied || code == -KEY_untie) {
 450                     ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
 451                     goto set;
 452                 }
 453                 if (code == -KEY_tie) {
 454                     ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
 455                     goto set;
 456                 }
 457                 if (code == -KEY_readpipe) {
 458                     s = "CORE::backtick";
 459                 }
 460                 while (i < MAXO) {      /* The slow way. */
 461                     if (strEQ(s + 6, PL_op_name[i])
 462                         || strEQ(s + 6, PL_op_desc[i]))
 463                     {
 464                         goto found;
 465                     }
 466                     i++;
 467                 }
 468                 goto nonesuch;          /* Should not happen... */
 469               found:
 470                 defgv = PL_opargs[i] & OA_DEFGV;
 471                 oa = PL_opargs[i] >> OASHIFT;
 472                 while (oa) {
 473                     if (oa & OA_OPTIONAL && !seen_question && !defgv) {
 474                         seen_question = 1;
 475                         str[n++] = ';';
 476                     }
 477                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 478                         && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
 479                         /* But globs are already references (kinda) */
 480                         && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
 481                     ) {
 482                         str[n++] = '\\';
 483                     }
 484                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 485                     oa = oa >> 4;
 486                 }
 487                 if (defgv && str[n - 1] == '$')
 488                     str[n - 1] = '_';
 489                 str[n++] = '\0';
 490                 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
 491             }
 492             else if (code)              /* Non-Overridable */
 493                 goto set;
 494             else {                      /* None such */
 495               nonesuch:
 496                 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
 497             }
 498         }
 499     }
 500     cv = sv_2cv(TOPs, &stash, &gv, 0);
 501     if (cv && SvPOK(cv))
 502         ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
 503   set:
 504     SETs(ret);
 505     RETURN;
 506 }
 507
 508 PP(pp_anoncode)
 509 {
 510     dVAR; dSP;
 511     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 512     if (CvCLONE(cv))
 513         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 514     EXTEND(SP,1);
 515     PUSHs(MUTABLE_SV(cv));
 516     RETURN;
 517 }
 518
 519 PP(pp_srefgen)
 520 {
 521     dVAR; dSP;
 522     *SP = refto(*SP);
 523     RETURN;
 524 }
 525
 526 PP(pp_refgen)
 527 {
 528     dVAR; dSP; dMARK;
 529     if (GIMME != G_ARRAY) {
 530         if (++MARK <= SP)
 531             *MARK = *SP;
 532         else
 533             *MARK = &PL_sv_undef;
 534         *MARK = refto(*MARK);
 535         SP = MARK;
 536         RETURN;
 537     }
 538     EXTEND_MORTAL(SP - MARK);
 539     while (++MARK <= SP)
 540         *MARK = refto(*MARK);
 541     RETURN;
 542 }
 543
 544 STATIC SV*
 545 S_refto(pTHX_ SV *sv)
 546 {
 547     dVAR;
 548     SV* rv;
 549
 550     PERL_ARGS_ASSERT_REFTO;
 551
 552     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 553         if (LvTARGLEN(sv))
 554             vivify_defelem(sv);
 555         if (!(sv = LvTARG(sv)))
 556             sv = &PL_sv_undef;
 557         else
 558             SvREFCNT_inc_void_NN(sv);
 559     }
 560     else if (SvTYPE(sv) == SVt_PVAV) {
 561         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 562             av_reify(MUTABLE_AV(sv));
 563         SvTEMP_off(sv);
 564         SvREFCNT_inc_void_NN(sv);
 565     }
 566     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 567         sv = newSVsv(sv);
 568     else {
 569         SvTEMP_off(sv);
 570         SvREFCNT_inc_void_NN(sv);
 571     }
 572     rv = sv_newmortal();
 573     sv_upgrade(rv, SVt_IV);
 574     SvRV_set(rv, sv);
 575     SvROK_on(rv);
 576     return rv;
 577 }
 578
 579 PP(pp_ref)
 580 {
 581     dVAR; dSP; dTARGET;
 582     const char *pv;
 583     SV * const sv = POPs;
 584
 585     if (sv)
 586         SvGETMAGIC(sv);
 587
 588     if (!sv || !SvROK(sv))
 589         RETPUSHNO;
 590
 591     pv = sv_reftype(SvRV(sv),TRUE);
 592     PUSHp(pv, strlen(pv));
 593     RETURN;
 594 }
 595
 596 PP(pp_bless)
 597 {
 598     dVAR; dSP;
 599     HV *stash;
 600
 601     if (MAXARG == 1)
 602         stash = CopSTASH(PL_curcop);
 603     else {
 604         SV * const ssv = POPs;
 605         STRLEN len;
 606         const char *ptr;
 607
 608         if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
 609             Perl_croak(aTHX_ "Attempt to bless into a reference");
 610         ptr = SvPV_const(ssv,len);
 611         if (len == 0)
 612             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 613                            "Explicit blessing to '' (assuming package main)");
 614         stash = gv_stashpvn(ptr, len, GV_ADD);
 615     }
 616
 617     (void)sv_bless(TOPs, stash);
 618     RETURN;
 619 }
 620
 621 PP(pp_gelem)
 622 {
 623     dVAR; dSP;
 624
 625     SV *sv = POPs;
 626     const char * const elem = SvPV_nolen_const(sv);
 627     GV * const gv = MUTABLE_GV(POPs);
 628     SV * tmpRef = NULL;
 629
 630     sv = NULL;
 631     if (elem) {
 632         /* elem will always be NUL terminated.  */
 633         const char * const second_letter = elem + 1;
 634         switch (*elem) {
 635         case 'A':
 636             if (strEQ(second_letter, "RRAY"))
 637                 tmpRef = MUTABLE_SV(GvAV(gv));
 638             break;
 639         case 'C':
 640             if (strEQ(second_letter, "ODE"))
 641                 tmpRef = MUTABLE_SV(GvCVu(gv));
 642             break;
 643         case 'F':
 644             if (strEQ(second_letter, "ILEHANDLE")) {
 645                 /* finally deprecated in 5.8.0 */
 646                 deprecate("*glob{FILEHANDLE}");
 647                 tmpRef = MUTABLE_SV(GvIOp(gv));
 648             }
 649             else
 650                 if (strEQ(second_letter, "ORMAT"))
 651                     tmpRef = MUTABLE_SV(GvFORM(gv));
 652             break;
 653         case 'G':
 654             if (strEQ(second_letter, "LOB"))
 655                 tmpRef = MUTABLE_SV(gv);
 656             break;
 657         case 'H':
 658             if (strEQ(second_letter, "ASH"))
 659                 tmpRef = MUTABLE_SV(GvHV(gv));
 660             break;
 661         case 'I':
 662             if (*second_letter == 'O' && !elem[2])
 663                 tmpRef = MUTABLE_SV(GvIOp(gv));
 664             break;
 665         case 'N':
 666             if (strEQ(second_letter, "AME"))
 667                 sv = newSVhek(GvNAME_HEK(gv));
 668             break;
 669         case 'P':
 670             if (strEQ(second_letter, "ACKAGE")) {
 671                 const HV * const stash = GvSTASH(gv);
 672                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 673                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 674             }
 675             break;
 676         case 'S':
 677             if (strEQ(second_letter, "CALAR"))
 678                 tmpRef = GvSVn(gv);
 679             break;
 680         }
 681     }
 682     if (tmpRef)
 683         sv = newRV(tmpRef);
 684     if (sv)
 685         sv_2mortal(sv);
 686     else
 687         sv = &PL_sv_undef;
 688     XPUSHs(sv);
 689     RETURN;
 690 }
 691
 692 /* Pattern matching */
 693
 694 PP(pp_study)
 695 {
 696     dVAR; dSP; dPOPss;
 697     register unsigned char *s;
 698     register I32 pos;
 699     register I32 ch;
 700     register I32 *sfirst;
 701     register I32 *snext;
 702     STRLEN len;
 703
 704     if (sv == PL_lastscream) {
 705         if (SvSCREAM(sv))
 706             RETPUSHYES;
 707     }
 708     s = (unsigned char*)(SvPV(sv, len));
 709     pos = len;
 710     if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
 711         /* No point in studying a zero length string, and not safe to study
 712            anything that doesn't appear to be a simple scalar (and hence might
 713            change between now and when the regexp engine runs without our set
 714            magic ever running) such as a reference to an object with overloaded
 715            stringification.  */
 716         RETPUSHNO;
 717     }
 718
 719     if (PL_lastscream) {
 720         SvSCREAM_off(PL_lastscream);
 721         SvREFCNT_dec(PL_lastscream);
 722     }
 723     PL_lastscream = SvREFCNT_inc_simple(sv);
 724
 725     s = (unsigned char*)(SvPV(sv, len));
 726     pos = len;
 727     if (pos <= 0)
 728         RETPUSHNO;
 729     if (pos > PL_maxscream) {
 730         if (PL_maxscream < 0) {
 731             PL_maxscream = pos + 80;
 732             Newx(PL_screamfirst, 256, I32);
 733             Newx(PL_screamnext, PL_maxscream, I32);
 734         }
 735         else {
 736             PL_maxscream = pos + pos / 4;
 737             Renew(PL_screamnext, PL_maxscream, I32);
 738         }
 739     }
 740
 741     sfirst = PL_screamfirst;
 742     snext = PL_screamnext;
 743
 744     if (!sfirst || !snext)
 745         DIE(aTHX_ "do_study: out of memory");
 746
 747     for (ch = 256; ch; --ch)
 748         *sfirst++ = -1;
 749     sfirst -= 256;
 750
 751     while (--pos >= 0) {
 752         register const I32 ch = s[pos];
 753         if (sfirst[ch] >= 0)
 754             snext[pos] = sfirst[ch] - pos;
 755         else
 756             snext[pos] = -pos;
 757         sfirst[ch] = pos;
 758     }
 759
 760     SvSCREAM_on(sv);
 761     /* piggyback on m//g magic */
 762     sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
 763     RETPUSHYES;
 764 }
 765
 766 PP(pp_trans)
 767 {
 768     dVAR; dSP; dTARG;
 769     SV *sv;
 770
 771     if (PL_op->op_flags & OPf_STACKED)
 772         sv = POPs;
 773     else if (PL_op->op_private & OPpTARGET_MY)
 774         sv = GETTARGET;
 775     else {
 776         sv = DEFSV;
 777         EXTEND(SP,1);
 778     }
 779     TARG = sv_newmortal();
 780     if(PL_op->op_type == OP_TRANSR) {
 781         SV * const newsv = newSVsv(sv);
 782         do_trans(newsv);
 783         mPUSHs(newsv);
 784     }
 785     else PUSHi(do_trans(sv));
 786     RETURN;
 787 }
 788
 789 /* Lvalue operators. */
 790
 791 PP(pp_schop)
 792 {
 793     dVAR; dSP; dTARGET;
 794     do_chop(TARG, TOPs);
 795     SETTARG;
 796     RETURN;
 797 }
 798
 799 PP(pp_chop)
 800 {
 801     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
 802     while (MARK < SP)
 803         do_chop(TARG, *++MARK);
 804     SP = ORIGMARK;
 805     XPUSHTARG;
 806     RETURN;
 807 }
 808
 809 PP(pp_schomp)
 810 {
 811     dVAR; dSP; dTARGET;
 812     SETi(do_chomp(TOPs));
 813     RETURN;
 814 }
 815
 816 PP(pp_chomp)
 817 {
 818     dVAR; dSP; dMARK; dTARGET;
 819     register I32 count = 0;
 820
 821     while (SP > MARK)
 822         count += do_chomp(POPs);
 823     XPUSHi(count);
 824     RETURN;
 825 }
 826
 827 PP(pp_undef)
 828 {
 829     dVAR; dSP;
 830     SV *sv;
 831
 832     if (!PL_op->op_private) {
 833         EXTEND(SP, 1);
 834         RETPUSHUNDEF;
 835     }
 836
 837     sv = POPs;
 838     if (!sv)
 839         RETPUSHUNDEF;
 840
 841     SV_CHECK_THINKFIRST_COW_DROP(sv);
 842
 843     switch (SvTYPE(sv)) {
 844     case SVt_NULL:
 845         break;
 846     case SVt_PVAV:
 847         av_undef(MUTABLE_AV(sv));
 848         break;
 849     case SVt_PVHV:
 850         hv_undef(MUTABLE_HV(sv));
 851         break;
 852     case SVt_PVCV:
 853         if (cv_const_sv((const CV *)sv))
 854             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
 855                            CvANON((const CV *)sv) ? "(anonymous)"
 856                            : GvENAME(CvGV((const CV *)sv)));
 857         /* FALLTHROUGH */
 858     case SVt_PVFM:
 859         {
 860             /* let user-undef'd sub keep its identity */
 861             GV* const gv = CvGV((const CV *)sv);
 862             cv_undef(MUTABLE_CV(sv));
 863             CvGV_set(MUTABLE_CV(sv), gv);
 864         }
 865         break;
 866     case SVt_PVGV:
 867         if (SvFAKE(sv)) {
 868             SvSetMagicSV(sv, &PL_sv_undef);
 869             break;
 870         }
 871         else if (isGV_with_GP(sv)) {
 872             GP *gp;
 873             HV *stash;
 874
 875             /* undef *Foo:: */
 876             if((stash = GvHV((const GV *)sv)) && HvENAME_get(stash))
 877                 mro_isa_changed_in(stash);
 878             /* undef *Pkg::meth_name ... */
 879             else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
 880                     && HvENAME_get(stash))
 881                 mro_method_changed_in(stash);
 882
 883             gp_free(MUTABLE_GV(sv));
 884             Newxz(gp, 1, GP);
 885             GvGP(sv) = gp_ref(gp);
 886             GvSV(sv) = newSV(0);
 887             GvLINE(sv) = CopLINE(PL_curcop);
 888             GvEGV(sv) = MUTABLE_GV(sv);
 889             GvMULTI_on(sv);
 890             break;
 891         }
 892         /* FALL THROUGH */
 893     default:
 894         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 895             SvPV_free(sv);
 896             SvPV_set(sv, NULL);
 897             SvLEN_set(sv, 0);
 898         }
 899         SvOK_off(sv);
 900         SvSETMAGIC(sv);
 901     }
 902
 903     RETPUSHUNDEF;
 904 }
 905
 906 PP(pp_predec)
 907 {
 908     dVAR; dSP;
 909     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 910         Perl_croak_no_modify(aTHX);
 911     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 912         && SvIVX(TOPs) != IV_MIN)
 913     {
 914         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 915         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 916     }
 917     else
 918         sv_dec(TOPs);
 919     SvSETMAGIC(TOPs);
 920     return NORMAL;
 921 }
 922
 923 PP(pp_postinc)
 924 {
 925     dVAR; dSP; dTARGET;
 926     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 927         Perl_croak_no_modify(aTHX);
 928     if (SvROK(TOPs))
 929         TARG = sv_newmortal();
 930     sv_setsv(TARG, TOPs);
 931     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 932         && SvIVX(TOPs) != IV_MAX)
 933     {
 934         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 935         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 936     }
 937     else
 938         sv_inc_nomg(TOPs);
 939     SvSETMAGIC(TOPs);
 940     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
 941     if (!SvOK(TARG))
 942         sv_setiv(TARG, 0);
 943     SETs(TARG);
 944     return NORMAL;
 945 }
 946
 947 PP(pp_postdec)
 948 {
 949     dVAR; dSP; dTARGET;
 950     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 951         Perl_croak_no_modify(aTHX);
 952     if (SvROK(TOPs))
 953         TARG = sv_newmortal();
 954     sv_setsv(TARG, TOPs);
 955     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 956         && SvIVX(TOPs) != IV_MIN)
 957     {
 958         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 959         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 960     }
 961     else
 962         sv_dec_nomg(TOPs);
 963     SvSETMAGIC(TOPs);
 964     SETs(TARG);
 965     return NORMAL;
 966 }
 967
 968 /* Ordinary operators. */
 969
 970 PP(pp_pow)
 971 {
 972     dVAR; dSP; dATARGET; SV *svl, *svr;
 973 #ifdef PERL_PRESERVE_IVUV
 974     bool is_int = 0;
 975 #endif
 976     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
 977     svr = TOPs;
 978     svl = TOPm1s;
 979 #ifdef PERL_PRESERVE_IVUV
 980     /* For integer to integer power, we do the calculation by hand wherever
 981        we're sure it is safe; otherwise we call pow() and try to convert to
 982        integer afterwards. */
 983     {
 984         SvIV_please_nomg(svr);
 985         if (SvIOK(svr)) {
 986             SvIV_please_nomg(svl);
 987             if (SvIOK(svl)) {
 988                 UV power;
 989                 bool baseuok;
 990                 UV baseuv;
 991
 992                 if (SvUOK(svr)) {
 993                     power = SvUVX(svr);
 994                 } else {
 995                     const IV iv = SvIVX(svr);
 996                     if (iv >= 0) {
 997                         power = iv;
 998                     } else {
 999                         goto float_it; /* Can't do negative powers this way.  */
1000                     }
1001                 }
1002
1003                 baseuok = SvUOK(svl);
1004                 if (baseuok) {
1005                     baseuv = SvUVX(svl);
1006                 } else {
1007                     const IV iv = SvIVX(svl);
1008                     if (iv >= 0) {
1009                         baseuv = iv;
1010                         baseuok = TRUE; /* effectively it's a UV now */
1011                     } else {
1012                         baseuv = -iv; /* abs, baseuok == false records sign */
1013                     }
1014                 }
1015                 /* now we have integer ** positive integer. */
1016                 is_int = 1;
1017
1018                 /* foo & (foo - 1) is zero only for a power of 2.  */
1019                 if (!(baseuv & (baseuv - 1))) {
1020                     /* We are raising power-of-2 to a positive integer.
1021                        The logic here will work for any base (even non-integer
1022                        bases) but it can be less accurate than
1023                        pow (base,power) or exp (power * log (base)) when the
1024                        intermediate values start to spill out of the mantissa.
1025                        With powers of 2 we know this can't happen.
1026                        And powers of 2 are the favourite thing for perl
1027                        programmers to notice ** not doing what they mean. */
1028                     NV result = 1.0;
1029                     NV base = baseuok ? baseuv : -(NV)baseuv;
1030
1031                     if (power & 1) {
1032                         result *= base;
1033                     }
1034                     while (power >>= 1) {
1035                         base *= base;
1036                         if (power & 1) {
1037                             result *= base;
1038                         }
1039                     }
1040                     SP--;
1041                     SETn( result );
1042                     SvIV_please_nomg(svr);
1043                     RETURN;
1044                 } else {
1045                     register unsigned int highbit = 8 * sizeof(UV);
1046                     register unsigned int diff = 8 * sizeof(UV);
1047                     while (diff >>= 1) {
1048                         highbit -= diff;
1049                         if (baseuv >> highbit) {
1050                             highbit += diff;
1051                         }
1052                     }
1053                     /* we now have baseuv < 2 ** highbit */
1054                     if (power * highbit <= 8 * sizeof(UV)) {
1055                         /* result will definitely fit in UV, so use UV math
1056                            on same algorithm as above */
1057                         register UV result = 1;
1058                         register UV base = baseuv;
1059                         const bool odd_power = cBOOL(power & 1);
1060                         if (odd_power) {
1061                             result *= base;
1062                         }
1063                         while (power >>= 1) {
1064                             base *= base;
1065                             if (power & 1) {
1066                                 result *= base;
1067                             }
1068                         }
1069                         SP--;
1070                         if (baseuok || !odd_power)
1071                             /* answer is positive */
1072                             SETu( result );
1073                         else if (result <= (UV)IV_MAX)
1074                             /* answer negative, fits in IV */
1075                             SETi( -(IV)result );
1076                         else if (result == (UV)IV_MIN)
1077                             /* 2's complement assumption: special case IV_MIN */
1078                             SETi( IV_MIN );
1079                         else
1080                             /* answer negative, doesn't fit */
1081                             SETn( -(NV)result );
1082                         RETURN;
1083                     }
1084                 }
1085             }
1086         }
1087     }
1088   float_it:
1089 #endif
1090     {
1091         NV right = SvNV_nomg(svr);
1092         NV left  = SvNV_nomg(svl);
1093         (void)POPs;
1094
1095 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1096     /*
1097     We are building perl with long double support and are on an AIX OS
1098     afflicted with a powl() function that wrongly returns NaNQ for any
1099     negative base.  This was reported to IBM as PMR #23047-379 on
1100     03/06/2006.  The problem exists in at least the following versions
1101     of AIX and the libm fileset, and no doubt others as well:
1102
1103         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1104         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1105         AIX 5.2.0           bos.adt.libm 5.2.0.85
1106
1107     So, until IBM fixes powl(), we provide the following workaround to
1108     handle the problem ourselves.  Our logic is as follows: for
1109     negative bases (left), we use fmod(right, 2) to check if the
1110     exponent is an odd or even integer:
1111
1112         - if odd,  powl(left, right) == -powl(-left, right)
1113         - if even, powl(left, right) ==  powl(-left, right)
1114
1115     If the exponent is not an integer, the result is rightly NaNQ, so
1116     we just return that (as NV_NAN).
1117     */
1118
1119         if (left < 0.0) {
1120             NV mod2 = Perl_fmod( right, 2.0 );
1121             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1122                 SETn( -Perl_pow( -left, right) );
1123             } else if (mod2 == 0.0) {           /* even integer */
1124                 SETn( Perl_pow( -left, right) );
1125             } else {                            /* fractional power */
1126                 SETn( NV_NAN );
1127             }
1128         } else {
1129             SETn( Perl_pow( left, right) );
1130         }
1131 #else
1132         SETn( Perl_pow( left, right) );
1133 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1134
1135 #ifdef PERL_PRESERVE_IVUV
1136         if (is_int)
1137             SvIV_please_nomg(svr);
1138 #endif
1139         RETURN;
1140     }
1141 }
1142
1143 PP(pp_multiply)
1144 {
1145     dVAR; dSP; dATARGET; SV *svl, *svr;
1146     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1147     svr = TOPs;
1148     svl = TOPm1s;
1149 #ifdef PERL_PRESERVE_IVUV
1150     SvIV_please_nomg(svr);
1151     if (SvIOK(svr)) {
1152         /* Unless the left argument is integer in range we are going to have to
1153            use NV maths. Hence only attempt to coerce the right argument if
1154            we know the left is integer.  */
1155         /* Left operand is defined, so is it IV? */
1156         SvIV_please_nomg(svl);
1157         if (SvIOK(svl)) {
1158             bool auvok = SvUOK(svl);
1159             bool buvok = SvUOK(svr);
1160             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1161             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1162             UV alow;
1163             UV ahigh;
1164             UV blow;
1165             UV bhigh;
1166
1167             if (auvok) {
1168                 alow = SvUVX(svl);
1169             } else {
1170                 const IV aiv = SvIVX(svl);
1171                 if (aiv >= 0) {
1172                     alow = aiv;
1173                     auvok = TRUE; /* effectively it's a UV now */
1174                 } else {
1175                     alow = -aiv; /* abs, auvok == false records sign */
1176                 }
1177             }
1178             if (buvok) {
1179                 blow = SvUVX(svr);
1180             } else {
1181                 const IV biv = SvIVX(svr);
1182                 if (biv >= 0) {
1183                     blow = biv;
1184                     buvok = TRUE; /* effectively it's a UV now */
1185                 } else {
1186                     blow = -biv; /* abs, buvok == false records sign */
1187                 }
1188             }
1189
1190             /* If this does sign extension on unsigned it's time for plan B  */
1191             ahigh = alow >> (4 * sizeof (UV));
1192             alow &= botmask;
1193             bhigh = blow >> (4 * sizeof (UV));
1194             blow &= botmask;
1195             if (ahigh && bhigh) {
1196                 NOOP;
1197                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1198                    which is overflow. Drop to NVs below.  */
1199             } else if (!ahigh && !bhigh) {
1200                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1201                    so the unsigned multiply cannot overflow.  */
1202                 const UV product = alow * blow;
1203                 if (auvok == buvok) {
1204                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1205                     SP--;
1206                     SETu( product );
1207                     RETURN;
1208                 } else if (product <= (UV)IV_MIN) {
1209                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1210                     /* -ve result, which could overflow an IV  */
1211                     SP--;
1212                     SETi( -(IV)product );
1213                     RETURN;
1214                 } /* else drop to NVs below. */
1215             } else {
1216                 /* One operand is large, 1 small */
1217                 UV product_middle;
1218                 if (bhigh) {
1219                     /* swap the operands */
1220                     ahigh = bhigh;
1221                     bhigh = blow; /* bhigh now the temp var for the swap */
1222                     blow = alow;
1223                     alow = bhigh;
1224                 }
1225                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1226                    multiplies can't overflow. shift can, add can, -ve can.  */
1227                 product_middle = ahigh * blow;
1228                 if (!(product_middle & topmask)) {
1229                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1230                     UV product_low;
1231                     product_middle <<= (4 * sizeof (UV));
1232                     product_low = alow * blow;
1233
1234                     /* as for pp_add, UV + something mustn't get smaller.
1235                        IIRC ANSI mandates this wrapping *behaviour* for
1236                        unsigned whatever the actual representation*/
1237                     product_low += product_middle;
1238                     if (product_low >= product_middle) {
1239                         /* didn't overflow */
1240                         if (auvok == buvok) {
1241                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1242                             SP--;
1243                             SETu( product_low );
1244                             RETURN;
1245                         } else if (product_low <= (UV)IV_MIN) {
1246                             /* 2s complement assumption again  */
1247                             /* -ve result, which could overflow an IV  */
1248                             SP--;
1249                             SETi( -(IV)product_low );
1250                             RETURN;
1251                         } /* else drop to NVs below. */
1252                     }
1253                 } /* product_middle too large */
1254             } /* ahigh && bhigh */
1255         } /* SvIOK(svl) */
1256     } /* SvIOK(svr) */
1257 #endif
1258     {
1259       NV right = SvNV_nomg(svr);
1260       NV left  = SvNV_nomg(svl);
1261       (void)POPs;
1262       SETn( left * right );
1263       RETURN;
1264     }
1265 }
1266
1267 PP(pp_divide)
1268 {
1269     dVAR; dSP; dATARGET; SV *svl, *svr;
1270     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1271     svr = TOPs;
1272     svl = TOPm1s;
1273     /* Only try to do UV divide first
1274        if ((SLOPPYDIVIDE is true) or
1275            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1276             to preserve))
1277        The assumption is that it is better to use floating point divide
1278        whenever possible, only doing integer divide first if we can't be sure.
1279        If NV_PRESERVES_UV is true then we know at compile time that no UV
1280        can be too large to preserve, so don't need to compile the code to
1281        test the size of UVs.  */
1282
1283 #ifdef SLOPPYDIVIDE
1284 #  define PERL_TRY_UV_DIVIDE
1285     /* ensure that 20./5. == 4. */
1286 #else
1287 #  ifdef PERL_PRESERVE_IVUV
1288 #    ifndef NV_PRESERVES_UV
1289 #      define PERL_TRY_UV_DIVIDE
1290 #    endif
1291 #  endif
1292 #endif
1293
1294 #ifdef PERL_TRY_UV_DIVIDE
1295     SvIV_please_nomg(svr);
1296     if (SvIOK(svr)) {
1297         SvIV_please_nomg(svl);
1298         if (SvIOK(svl)) {
1299             bool left_non_neg = SvUOK(svl);
1300             bool right_non_neg = SvUOK(svr);
1301             UV left;
1302             UV right;
1303
1304             if (right_non_neg) {
1305                 right = SvUVX(svr);
1306             }
1307             else {
1308                 const IV biv = SvIVX(svr);
1309                 if (biv >= 0) {
1310                     right = biv;
1311                     right_non_neg = TRUE; /* effectively it's a UV now */
1312                 }
1313                 else {
1314                     right = -biv;
1315                 }
1316             }
1317             /* historically undef()/0 gives a "Use of uninitialized value"
1318                warning before dieing, hence this test goes here.
1319                If it were immediately before the second SvIV_please, then
1320                DIE() would be invoked before left was even inspected, so
1321                no inpsection would give no warning.  */
1322             if (right == 0)
1323                 DIE(aTHX_ "Illegal division by zero");
1324
1325             if (left_non_neg) {
1326                 left = SvUVX(svl);
1327             }
1328             else {
1329                 const IV aiv = SvIVX(svl);
1330                 if (aiv >= 0) {
1331                     left = aiv;
1332                     left_non_neg = TRUE; /* effectively it's a UV now */
1333                 }
1334                 else {
1335                     left = -aiv;
1336                 }
1337             }
1338
1339             if (left >= right
1340 #ifdef SLOPPYDIVIDE
1341                 /* For sloppy divide we always attempt integer division.  */
1342 #else
1343                 /* Otherwise we only attempt it if either or both operands
1344                    would not be preserved by an NV.  If both fit in NVs
1345                    we fall through to the NV divide code below.  However,
1346                    as left >= right to ensure integer result here, we know that
1347                    we can skip the test on the right operand - right big
1348                    enough not to be preserved can't get here unless left is
1349                    also too big.  */
1350
1351                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1352 #endif
1353                 ) {
1354                 /* Integer division can't overflow, but it can be imprecise.  */
1355                 const UV result = left / right;
1356                 if (result * right == left) {
1357                     SP--; /* result is valid */
1358                     if (left_non_neg == right_non_neg) {
1359                         /* signs identical, result is positive.  */
1360                         SETu( result );
1361                         RETURN;
1362                     }
1363                     /* 2s complement assumption */
1364                     if (result <= (UV)IV_MIN)
1365                         SETi( -(IV)result );
1366                     else {
1367                         /* It's exact but too negative for IV. */
1368                         SETn( -(NV)result );
1369                     }
1370                     RETURN;
1371                 } /* tried integer divide but it was not an integer result */
1372             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1373         } /* left wasn't SvIOK */
1374     } /* right wasn't SvIOK */
1375 #endif /* PERL_TRY_UV_DIVIDE */
1376     {
1377         NV right = SvNV_nomg(svr);
1378         NV left  = SvNV_nomg(svl);
1379         (void)POPs;(void)POPs;
1380 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1381         if (! Perl_isnan(right) && right == 0.0)
1382 #else
1383         if (right == 0.0)
1384 #endif
1385             DIE(aTHX_ "Illegal division by zero");
1386         PUSHn( left / right );
1387         RETURN;
1388     }
1389 }
1390
1391 PP(pp_modulo)
1392 {
1393     dVAR; dSP; dATARGET;
1394     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1395     {
1396         UV left  = 0;
1397         UV right = 0;
1398         bool left_neg = FALSE;
1399         bool right_neg = FALSE;
1400         bool use_double = FALSE;
1401         bool dright_valid = FALSE;
1402         NV dright = 0.0;
1403         NV dleft  = 0.0;
1404         SV * const svr = TOPs;
1405         SV * const svl = TOPm1s;
1406         SvIV_please_nomg(svr);
1407         if (SvIOK(svr)) {
1408             right_neg = !SvUOK(svr);
1409             if (!right_neg) {
1410                 right = SvUVX(svr);
1411             } else {
1412                 const IV biv = SvIVX(svr);
1413                 if (biv >= 0) {
1414                     right = biv;
1415                     right_neg = FALSE; /* effectively it's a UV now */
1416                 } else {
1417                     right = -biv;
1418                 }
1419             }
1420         }
1421         else {
1422             dright = SvNV_nomg(svr);
1423             right_neg = dright < 0;
1424             if (right_neg)
1425                 dright = -dright;
1426             if (dright < UV_MAX_P1) {
1427                 right = U_V(dright);
1428                 dright_valid = TRUE; /* In case we need to use double below.  */
1429             } else {
1430                 use_double = TRUE;
1431             }
1432         }
1433
1434         /* At this point use_double is only true if right is out of range for
1435            a UV.  In range NV has been rounded down to nearest UV and
1436            use_double false.  */
1437         SvIV_please_nomg(svl);
1438         if (!use_double && SvIOK(svl)) {
1439             if (SvIOK(svl)) {
1440                 left_neg = !SvUOK(svl);
1441                 if (!left_neg) {
1442                     left = SvUVX(svl);
1443                 } else {
1444                     const IV aiv = SvIVX(svl);
1445                     if (aiv >= 0) {
1446                         left = aiv;
1447                         left_neg = FALSE; /* effectively it's a UV now */
1448                     } else {
1449                         left = -aiv;
1450                     }
1451                 }
1452             }
1453         }
1454         else {
1455             dleft = SvNV_nomg(svl);
1456             left_neg = dleft < 0;
1457             if (left_neg)
1458                 dleft = -dleft;
1459
1460             /* This should be exactly the 5.6 behaviour - if left and right are
1461                both in range for UV then use U_V() rather than floor.  */
1462             if (!use_double) {
1463                 if (dleft < UV_MAX_P1) {
1464                     /* right was in range, so is dleft, so use UVs not double.
1465                      */
1466                     left = U_V(dleft);
1467                 }
1468                 /* left is out of range for UV, right was in range, so promote
1469                    right (back) to double.  */
1470                 else {
1471                     /* The +0.5 is used in 5.6 even though it is not strictly
1472                        consistent with the implicit +0 floor in the U_V()
1473                        inside the #if 1. */
1474                     dleft = Perl_floor(dleft + 0.5);
1475                     use_double = TRUE;
1476                     if (dright_valid)
1477                         dright = Perl_floor(dright + 0.5);
1478                     else
1479                         dright = right;
1480                 }
1481             }
1482         }
1483         sp -= 2;
1484         if (use_double) {
1485             NV dans;
1486
1487             if (!dright)
1488                 DIE(aTHX_ "Illegal modulus zero");
1489
1490             dans = Perl_fmod(dleft, dright);
1491             if ((left_neg != right_neg) && dans)
1492                 dans = dright - dans;
1493             if (right_neg)
1494                 dans = -dans;
1495             sv_setnv(TARG, dans);
1496         }
1497         else {
1498             UV ans;
1499
1500             if (!right)
1501                 DIE(aTHX_ "Illegal modulus zero");
1502
1503             ans = left % right;
1504             if ((left_neg != right_neg) && ans)
1505                 ans = right - ans;
1506             if (right_neg) {
1507                 /* XXX may warn: unary minus operator applied to unsigned type */
1508                 /* could change -foo to be (~foo)+1 instead     */
1509                 if (ans <= ~((UV)IV_MAX)+1)
1510                     sv_setiv(TARG, ~ans+1);
1511                 else
1512                     sv_setnv(TARG, -(NV)ans);
1513             }
1514             else
1515                 sv_setuv(TARG, ans);
1516         }
1517         PUSHTARG;
1518         RETURN;
1519     }
1520 }
1521
1522 PP(pp_repeat)
1523 {
1524     dVAR; dSP; dATARGET;
1525     register IV count;
1526     SV *sv;
1527
1528     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1529         /* TODO: think of some way of doing list-repeat overloading ??? */
1530         sv = POPs;
1531         SvGETMAGIC(sv);
1532     }
1533     else {
1534         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1535         sv = POPs;
1536     }
1537
1538     if (SvIOKp(sv)) {
1539          if (SvUOK(sv)) {
1540               const UV uv = SvUV_nomg(sv);
1541               if (uv > IV_MAX)
1542                    count = IV_MAX; /* The best we can do? */
1543               else
1544                    count = uv;
1545          } else {
1546               const IV iv = SvIV_nomg(sv);
1547               if (iv < 0)
1548                    count = 0;
1549               else
1550                    count = iv;
1551          }
1552     }
1553     else if (SvNOKp(sv)) {
1554          const NV nv = SvNV_nomg(sv);
1555          if (nv < 0.0)
1556               count = 0;
1557          else
1558               count = (IV)nv;
1559     }
1560     else
1561          count = SvIV_nomg(sv);
1562
1563     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1564         dMARK;
1565         static const char oom_list_extend[] = "Out of memory during list extend";
1566         const I32 items = SP - MARK;
1567         const I32 max = items * count;
1568
1569         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1570         /* Did the max computation overflow? */
1571         if (items > 0 && max > 0 && (max < items || max < count))
1572            Perl_croak(aTHX_ oom_list_extend);
1573         MEXTEND(MARK, max);
1574         if (count > 1) {
1575             while (SP > MARK) {
1576 #if 0
1577               /* This code was intended to fix 20010809.028:
1578
1579                  $x = 'abcd';
1580                  for (($x =~ /./g) x 2) {
1581                      print chop; # "abcdabcd" expected as output.
1582                  }
1583
1584                * but that change (#11635) broke this code:
1585
1586                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1587
1588                * I can't think of a better fix that doesn't introduce
1589                * an efficiency hit by copying the SVs. The stack isn't
1590                * refcounted, and mortalisation obviously doesn't
1591                * Do The Right Thing when the stack has more than
1592                * one pointer to the same mortal value.
1593                * .robin.
1594                */
1595                 if (*SP) {
1596                     *SP = sv_2mortal(newSVsv(*SP));
1597                     SvREADONLY_on(*SP);
1598                 }
1599 #else
1600                if (*SP)
1601                    SvTEMP_off((*SP));
1602 #endif
1603                 SP--;
1604             }
1605             MARK++;
1606             repeatcpy((char*)(MARK + items), (char*)MARK,
1607                 items * sizeof(const SV *), count - 1);
1608             SP += max;
1609         }
1610         else if (count <= 0)
1611             SP -= items;
1612     }
1613     else {      /* Note: mark already snarfed by pp_list */
1614         SV * const tmpstr = POPs;
1615         STRLEN len;
1616         bool isutf;
1617         static const char oom_string_extend[] =
1618           "Out of memory during string extend";
1619
1620         if (TARG != tmpstr)
1621             sv_setsv_nomg(TARG, tmpstr);
1622         SvPV_force_nomg(TARG, len);
1623         isutf = DO_UTF8(TARG);
1624         if (count != 1) {
1625             if (count < 1)
1626                 SvCUR_set(TARG, 0);
1627             else {
1628                 const STRLEN max = (UV)count * len;
1629                 if (len > MEM_SIZE_MAX / count)
1630                      Perl_croak(aTHX_ oom_string_extend);
1631                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1632                 SvGROW(TARG, max + 1);
1633                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1634                 SvCUR_set(TARG, SvCUR(TARG) * count);
1635             }
1636             *SvEND(TARG) = '\0';
1637         }
1638         if (isutf)
1639             (void)SvPOK_only_UTF8(TARG);
1640         else
1641             (void)SvPOK_only(TARG);
1642
1643         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1644             /* The parser saw this as a list repeat, and there
1645                are probably several items on the stack. But we're
1646                in scalar context, and there's no pp_list to save us
1647                now. So drop the rest of the items -- robin@kitsite.com
1648              */
1649             dMARK;
1650             SP = MARK;
1651         }
1652         PUSHTARG;
1653     }
1654     RETURN;
1655 }
1656
1657 PP(pp_subtract)
1658 {
1659     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1660     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1661     svr = TOPs;
1662     svl = TOPm1s;
1663     useleft = USE_LEFT(svl);
1664 #ifdef PERL_PRESERVE_IVUV
1665     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1666        "bad things" happen if you rely on signed integers wrapping.  */
1667     SvIV_please_nomg(svr);
1668     if (SvIOK(svr)) {
1669         /* Unless the left argument is integer in range we are going to have to
1670            use NV maths. Hence only attempt to coerce the right argument if
1671            we know the left is integer.  */
1672         register UV auv = 0;
1673         bool auvok = FALSE;
1674         bool a_valid = 0;
1675
1676         if (!useleft) {
1677             auv = 0;
1678             a_valid = auvok = 1;
1679             /* left operand is undef, treat as zero.  */
1680         } else {
1681             /* Left operand is defined, so is it IV? */
1682             SvIV_please_nomg(svl);
1683             if (SvIOK(svl)) {
1684                 if ((auvok = SvUOK(svl)))
1685                     auv = SvUVX(svl);
1686                 else {
1687                     register const IV aiv = SvIVX(svl);
1688                     if (aiv >= 0) {
1689                         auv = aiv;
1690                         auvok = 1;      /* Now acting as a sign flag.  */
1691                     } else { /* 2s complement assumption for IV_MIN */
1692                         auv = (UV)-aiv;
1693                     }
1694                 }
1695                 a_valid = 1;
1696             }
1697         }
1698         if (a_valid) {
1699             bool result_good = 0;
1700             UV result;
1701             register UV buv;
1702             bool buvok = SvUOK(svr);
1703
1704             if (buvok)
1705                 buv = SvUVX(svr);
1706             else {
1707                 register const IV biv = SvIVX(svr);
1708                 if (biv >= 0) {
1709                     buv = biv;
1710                     buvok = 1;
1711                 } else
1712                     buv = (UV)-biv;
1713             }
1714             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1715                else "IV" now, independent of how it came in.
1716                if a, b represents positive, A, B negative, a maps to -A etc
1717                a - b =>  (a - b)
1718                A - b => -(a + b)
1719                a - B =>  (a + b)
1720                A - B => -(a - b)
1721                all UV maths. negate result if A negative.
1722                subtract if signs same, add if signs differ. */
1723
1724             if (auvok ^ buvok) {
1725                 /* Signs differ.  */
1726                 result = auv + buv;
1727                 if (result >= auv)
1728                     result_good = 1;
1729             } else {
1730                 /* Signs same */
1731                 if (auv >= buv) {
1732                     result = auv - buv;
1733                     /* Must get smaller */
1734                     if (result <= auv)
1735                         result_good = 1;
1736                 } else {
1737                     result = buv - auv;
1738                     if (result <= buv) {
1739                         /* result really should be -(auv-buv). as its negation
1740                            of true value, need to swap our result flag  */
1741                         auvok = !auvok;
1742                         result_good = 1;
1743                     }
1744                 }
1745             }
1746             if (result_good) {
1747                 SP--;
1748                 if (auvok)
1749                     SETu( result );
1750                 else {
1751                     /* Negate result */
1752                     if (result <= (UV)IV_MIN)
1753                         SETi( -(IV)result );
1754                     else {
1755                         /* result valid, but out of range for IV.  */
1756                         SETn( -(NV)result );
1757                     }
1758                 }
1759                 RETURN;
1760             } /* Overflow, drop through to NVs.  */
1761         }
1762     }
1763 #endif
1764     {
1765         NV value = SvNV_nomg(svr);
1766         (void)POPs;
1767
1768         if (!useleft) {
1769             /* left operand is undef, treat as zero - value */
1770             SETn(-value);
1771             RETURN;
1772         }
1773         SETn( SvNV_nomg(svl) - value );
1774         RETURN;
1775     }
1776 }
1777
1778 PP(pp_left_shift)
1779 {
1780     dVAR; dSP; dATARGET; SV *svl, *svr;
1781     tryAMAGICbin_MG(lshift_amg, AMGf_assign);
1782     svr = POPs;
1783     svl = TOPs;
1784     {
1785       const IV shift = SvIV_nomg(svr);
1786       if (PL_op->op_private & HINT_INTEGER) {
1787         const IV i = SvIV_nomg(svl);
1788         SETi(i << shift);
1789       }
1790       else {
1791         const UV u = SvUV_nomg(svl);
1792         SETu(u << shift);
1793       }
1794       RETURN;
1795     }
1796 }
1797
1798 PP(pp_right_shift)
1799 {
1800     dVAR; dSP; dATARGET; SV *svl, *svr;
1801     tryAMAGICbin_MG(rshift_amg, AMGf_assign);
1802     svr = POPs;
1803     svl = TOPs;
1804     {
1805       const IV shift = SvIV_nomg(svr);
1806       if (PL_op->op_private & HINT_INTEGER) {
1807         const IV i = SvIV_nomg(svl);
1808         SETi(i >> shift);
1809       }
1810       else {
1811         const UV u = SvUV_nomg(svl);
1812         SETu(u >> shift);
1813       }
1814       RETURN;
1815     }
1816 }
1817
1818 PP(pp_lt)
1819 {
1820     dVAR; dSP;
1821     tryAMAGICbin_MG(lt_amg, AMGf_set);
1822 #ifdef PERL_PRESERVE_IVUV
1823     SvIV_please_nomg(TOPs);
1824     if (SvIOK(TOPs)) {
1825         SvIV_please_nomg(TOPm1s);
1826         if (SvIOK(TOPm1s)) {
1827             bool auvok = SvUOK(TOPm1s);
1828             bool buvok = SvUOK(TOPs);
1829
1830             if (!auvok && !buvok) { /* ## IV < IV ## */
1831                 const IV aiv = SvIVX(TOPm1s);
1832                 const IV biv = SvIVX(TOPs);
1833
1834                 SP--;
1835                 SETs(boolSV(aiv < biv));
1836                 RETURN;
1837             }
1838             if (auvok && buvok) { /* ## UV < UV ## */
1839                 const UV auv = SvUVX(TOPm1s);
1840                 const UV buv = SvUVX(TOPs);
1841
1842                 SP--;
1843                 SETs(boolSV(auv < buv));
1844                 RETURN;
1845             }
1846             if (auvok) { /* ## UV < IV ## */
1847                 UV auv;
1848                 const IV biv = SvIVX(TOPs);
1849                 SP--;
1850                 if (biv < 0) {
1851                     /* As (a) is a UV, it's >=0, so it cannot be < */
1852                     SETs(&PL_sv_no);
1853                     RETURN;
1854                 }
1855                 auv = SvUVX(TOPs);
1856                 SETs(boolSV(auv < (UV)biv));
1857                 RETURN;
1858             }
1859             { /* ## IV < UV ## */
1860                 const IV aiv = SvIVX(TOPm1s);
1861                 UV buv;
1862
1863                 if (aiv < 0) {
1864                     /* As (b) is a UV, it's >=0, so it must be < */
1865                     SP--;
1866                     SETs(&PL_sv_yes);
1867                     RETURN;
1868                 }
1869                 buv = SvUVX(TOPs);
1870                 SP--;
1871                 SETs(boolSV((UV)aiv < buv));
1872                 RETURN;
1873             }
1874         }
1875     }
1876 #endif
1877 #ifndef NV_PRESERVES_UV
1878 #ifdef PERL_PRESERVE_IVUV
1879     else
1880 #endif
1881     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1882         SP--;
1883         SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1884         RETURN;
1885     }
1886 #endif
1887     {
1888 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1889       dPOPTOPnnrl_nomg;
1890       if (Perl_isnan(left) || Perl_isnan(right))
1891           RETSETNO;
1892       SETs(boolSV(left < right));
1893 #else
1894       dPOPnv_nomg;
1895       SETs(boolSV(SvNV_nomg(TOPs) < value));
1896 #endif
1897       RETURN;
1898     }
1899 }
1900
1901 PP(pp_gt)
1902 {
1903     dVAR; dSP;
1904     tryAMAGICbin_MG(gt_amg, AMGf_set);
1905 #ifdef PERL_PRESERVE_IVUV
1906     SvIV_please_nomg(TOPs);
1907     if (SvIOK(TOPs)) {
1908         SvIV_please_nomg(TOPm1s);
1909         if (SvIOK(TOPm1s)) {
1910             bool auvok = SvUOK(TOPm1s);
1911             bool buvok = SvUOK(TOPs);
1912
1913             if (!auvok && !buvok) { /* ## IV > IV ## */
1914                 const IV aiv = SvIVX(TOPm1s);
1915                 const IV biv = SvIVX(TOPs);
1916
1917                 SP--;
1918                 SETs(boolSV(aiv > biv));
1919                 RETURN;
1920             }
1921             if (auvok && buvok) { /* ## UV > UV ## */
1922                 const UV auv = SvUVX(TOPm1s);
1923                 const UV buv = SvUVX(TOPs);
1924
1925                 SP--;
1926                 SETs(boolSV(auv > buv));
1927                 RETURN;
1928             }
1929             if (auvok) { /* ## UV > IV ## */
1930                 UV auv;
1931                 const IV biv = SvIVX(TOPs);
1932
1933                 SP--;
1934                 if (biv < 0) {
1935                     /* As (a) is a UV, it's >=0, so it must be > */
1936                     SETs(&PL_sv_yes);
1937                     RETURN;
1938                 }
1939                 auv = SvUVX(TOPs);
1940                 SETs(boolSV(auv > (UV)biv));
1941                 RETURN;
1942             }
1943             { /* ## IV > UV ## */
1944                 const IV aiv = SvIVX(TOPm1s);
1945                 UV buv;
1946
1947                 if (aiv < 0) {
1948                     /* As (b) is a UV, it's >=0, so it cannot be > */
1949                     SP--;
1950                     SETs(&PL_sv_no);
1951                     RETURN;
1952                 }
1953                 buv = SvUVX(TOPs);
1954                 SP--;
1955                 SETs(boolSV((UV)aiv > buv));
1956                 RETURN;
1957             }
1958         }
1959     }
1960 #endif
1961 #ifndef NV_PRESERVES_UV
1962 #ifdef PERL_PRESERVE_IVUV
1963     else
1964 #endif
1965     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1966         SP--;
1967         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1968         RETURN;
1969     }
1970 #endif
1971     {
1972 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1973       dPOPTOPnnrl_nomg;
1974       if (Perl_isnan(left) || Perl_isnan(right))
1975           RETSETNO;
1976       SETs(boolSV(left > right));
1977 #else
1978       dPOPnv_nomg;
1979       SETs(boolSV(SvNV_nomg(TOPs) > value));
1980 #endif
1981       RETURN;
1982     }
1983 }
1984
1985 PP(pp_le)
1986 {
1987     dVAR; dSP;
1988     tryAMAGICbin_MG(le_amg, AMGf_set);
1989 #ifdef PERL_PRESERVE_IVUV
1990     SvIV_please_nomg(TOPs);
1991     if (SvIOK(TOPs)) {
1992         SvIV_please_nomg(TOPm1s);
1993         if (SvIOK(TOPm1s)) {
1994             bool auvok = SvUOK(TOPm1s);
1995             bool buvok = SvUOK(TOPs);
1996
1997             if (!auvok && !buvok) { /* ## IV <= IV ## */
1998                 const IV aiv = SvIVX(TOPm1s);
1999                 const IV biv = SvIVX(TOPs);
2000
2001                 SP--;
2002                 SETs(boolSV(aiv <= biv));
2003                 RETURN;
2004             }
2005             if (auvok && buvok) { /* ## UV <= UV ## */
2006                 UV auv = SvUVX(TOPm1s);
2007                 UV buv = SvUVX(TOPs);
2008
2009                 SP--;
2010                 SETs(boolSV(auv <= buv));
2011                 RETURN;
2012             }
2013             if (auvok) { /* ## UV <= IV ## */
2014                 UV auv;
2015                 const IV biv = SvIVX(TOPs);
2016
2017                 SP--;
2018                 if (biv < 0) {
2019                     /* As (a) is a UV, it's >=0, so a cannot be <= */
2020                     SETs(&PL_sv_no);
2021                     RETURN;
2022                 }
2023                 auv = SvUVX(TOPs);
2024                 SETs(boolSV(auv <= (UV)biv));
2025                 RETURN;
2026             }
2027             { /* ## IV <= UV ## */
2028                 const IV aiv = SvIVX(TOPm1s);
2029                 UV buv;
2030
2031                 if (aiv < 0) {
2032                     /* As (b) is a UV, it's >=0, so a must be <= */
2033                     SP--;
2034                     SETs(&PL_sv_yes);
2035                     RETURN;
2036                 }
2037                 buv = SvUVX(TOPs);
2038                 SP--;
2039                 SETs(boolSV((UV)aiv <= buv));
2040                 RETURN;
2041             }
2042         }
2043     }
2044 #endif
2045 #ifndef NV_PRESERVES_UV
2046 #ifdef PERL_PRESERVE_IVUV
2047     else
2048 #endif
2049     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2050         SP--;
2051         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2052         RETURN;
2053     }
2054 #endif
2055     {
2056 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2057       dPOPTOPnnrl_nomg;
2058       if (Perl_isnan(left) || Perl_isnan(right))
2059           RETSETNO;
2060       SETs(boolSV(left <= right));
2061 #else
2062       dPOPnv_nomg;
2063       SETs(boolSV(SvNV_nomg(TOPs) <= value));
2064 #endif
2065       RETURN;
2066     }
2067 }
2068
2069 PP(pp_ge)
2070 {
2071     dVAR; dSP;
2072     tryAMAGICbin_MG(ge_amg,AMGf_set);
2073 #ifdef PERL_PRESERVE_IVUV
2074     SvIV_please_nomg(TOPs);
2075     if (SvIOK(TOPs)) {
2076         SvIV_please_nomg(TOPm1s);
2077         if (SvIOK(TOPm1s)) {
2078             bool auvok = SvUOK(TOPm1s);
2079             bool buvok = SvUOK(TOPs);
2080
2081             if (!auvok && !buvok) { /* ## IV >= IV ## */
2082                 const IV aiv = SvIVX(TOPm1s);
2083                 const IV biv = SvIVX(TOPs);
2084
2085                 SP--;
2086                 SETs(boolSV(aiv >= biv));
2087                 RETURN;
2088             }
2089             if (auvok && buvok) { /* ## UV >= UV ## */
2090                 const UV auv = SvUVX(TOPm1s);
2091                 const UV buv = SvUVX(TOPs);
2092
2093                 SP--;
2094                 SETs(boolSV(auv >= buv));
2095                 RETURN;
2096             }
2097             if (auvok) { /* ## UV >= IV ## */
2098                 UV auv;
2099                 const IV biv = SvIVX(TOPs);
2100
2101                 SP--;
2102                 if (biv < 0) {
2103                     /* As (a) is a UV, it's >=0, so it must be >= */
2104                     SETs(&PL_sv_yes);
2105                     RETURN;
2106                 }
2107                 auv = SvUVX(TOPs);
2108                 SETs(boolSV(auv >= (UV)biv));
2109                 RETURN;
2110             }
2111             { /* ## IV >= UV ## */
2112                 const IV aiv = SvIVX(TOPm1s);
2113                 UV buv;
2114
2115                 if (aiv < 0) {
2116                     /* As (b) is a UV, it's >=0, so a cannot be >= */
2117                     SP--;
2118                     SETs(&PL_sv_no);
2119                     RETURN;
2120                 }
2121                 buv = SvUVX(TOPs);
2122                 SP--;
2123                 SETs(boolSV((UV)aiv >= buv));
2124                 RETURN;
2125             }
2126         }
2127     }
2128 #endif
2129 #ifndef NV_PRESERVES_UV
2130 #ifdef PERL_PRESERVE_IVUV
2131     else
2132 #endif
2133     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2134         SP--;
2135         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2136         RETURN;
2137     }
2138 #endif
2139     {
2140 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2141       dPOPTOPnnrl_nomg;
2142       if (Perl_isnan(left) || Perl_isnan(right))
2143           RETSETNO;
2144       SETs(boolSV(left >= right));
2145 #else
2146       dPOPnv_nomg;
2147       SETs(boolSV(SvNV_nomg(TOPs) >= value));
2148 #endif
2149       RETURN;
2150     }
2151 }
2152
2153 PP(pp_ne)
2154 {
2155     dVAR; dSP;
2156     tryAMAGICbin_MG(ne_amg,AMGf_set);
2157 #ifndef NV_PRESERVES_UV
2158     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2159         SP--;
2160         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2161         RETURN;
2162     }
2163 #endif
2164 #ifdef PERL_PRESERVE_IVUV
2165     SvIV_please_nomg(TOPs);
2166     if (SvIOK(TOPs)) {
2167         SvIV_please_nomg(TOPm1s);
2168         if (SvIOK(TOPm1s)) {
2169             const bool auvok = SvUOK(TOPm1s);
2170             const bool buvok = SvUOK(TOPs);
2171
2172             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2173                 /* Casting IV to UV before comparison isn't going to matter
2174                    on 2s complement. On 1s complement or sign&magnitude
2175                    (if we have any of them) it could make negative zero
2176                    differ from normal zero. As I understand it. (Need to
2177                    check - is negative zero implementation defined behaviour
2178                    anyway?). NWC  */
2179                 const UV buv = SvUVX(POPs);
2180                 const UV auv = SvUVX(TOPs);
2181
2182                 SETs(boolSV(auv != buv));
2183                 RETURN;
2184             }
2185             {                   /* ## Mixed IV,UV ## */
2186                 IV iv;
2187                 UV uv;
2188
2189                 /* != is commutative so swap if needed (save code) */
2190                 if (auvok) {
2191                     /* swap. top of stack (b) is the iv */
2192                     iv = SvIVX(TOPs);
2193                     SP--;
2194                     if (iv < 0) {
2195                         /* As (a) is a UV, it's >0, so it cannot be == */
2196                         SETs(&PL_sv_yes);
2197                         RETURN;
2198                     }
2199                     uv = SvUVX(TOPs);
2200                 } else {
2201                     iv = SvIVX(TOPm1s);
2202                     SP--;
2203                     if (iv < 0) {
2204                         /* As (b) is a UV, it's >0, so it cannot be == */
2205                         SETs(&PL_sv_yes);
2206                         RETURN;
2207                     }
2208                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2209                 }
2210                 SETs(boolSV((UV)iv != uv));
2211                 RETURN;
2212             }
2213         }
2214     }
2215 #endif
2216     {
2217 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2218       dPOPTOPnnrl_nomg;
2219       if (Perl_isnan(left) || Perl_isnan(right))
2220           RETSETYES;
2221       SETs(boolSV(left != right));
2222 #else
2223       dPOPnv_nomg;
2224       SETs(boolSV(SvNV_nomg(TOPs) != value));
2225 #endif
2226       RETURN;
2227     }
2228 }
2229
2230 PP(pp_ncmp)
2231 {
2232     dVAR; dSP; dTARGET;
2233     tryAMAGICbin_MG(ncmp_amg, 0);
2234 #ifndef NV_PRESERVES_UV
2235     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2236         const UV right = PTR2UV(SvRV(POPs));
2237         const UV left = PTR2UV(SvRV(TOPs));
2238         SETi((left > right) - (left < right));
2239         RETURN;
2240     }
2241 #endif
2242 #ifdef PERL_PRESERVE_IVUV
2243     /* Fortunately it seems NaN isn't IOK */
2244     SvIV_please_nomg(TOPs);
2245     if (SvIOK(TOPs)) {
2246         SvIV_please_nomg(TOPm1s);
2247         if (SvIOK(TOPm1s)) {
2248             const bool leftuvok = SvUOK(TOPm1s);
2249             const bool rightuvok = SvUOK(TOPs);
2250             I32 value;
2251             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2252                 const IV leftiv = SvIVX(TOPm1s);
2253                 const IV rightiv = SvIVX(TOPs);
2254
2255                 if (leftiv > rightiv)
2256                     value = 1;
2257                 else if (leftiv < rightiv)
2258                     value = -1;
2259                 else
2260                     value = 0;
2261             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2262                 const UV leftuv = SvUVX(TOPm1s);
2263                 const UV rightuv = SvUVX(TOPs);
2264
2265                 if (leftuv > rightuv)
2266                     value = 1;
2267                 else if (leftuv < rightuv)
2268                     value = -1;
2269                 else
2270                     value = 0;
2271             } else if (leftuvok) { /* ## UV <=> IV ## */
2272                 const IV rightiv = SvIVX(TOPs);
2273                 if (rightiv < 0) {
2274                     /* As (a) is a UV, it's >=0, so it cannot be < */
2275                     value = 1;
2276                 } else {
2277                     const UV leftuv = SvUVX(TOPm1s);
2278                     if (leftuv > (UV)rightiv) {
2279                         value = 1;
2280                     } else if (leftuv < (UV)rightiv) {
2281                         value = -1;
2282                     } else {
2283                         value = 0;
2284                     }
2285                 }
2286             } else { /* ## IV <=> UV ## */
2287                 const IV leftiv = SvIVX(TOPm1s);
2288                 if (leftiv < 0) {
2289                     /* As (b) is a UV, it's >=0, so it must be < */
2290                     value = -1;
2291                 } else {
2292                     const UV rightuv = SvUVX(TOPs);
2293                     if ((UV)leftiv > rightuv) {
2294                         value = 1;
2295                     } else if ((UV)leftiv < rightuv) {
2296                         value = -1;
2297                     } else {
2298                         value = 0;
2299                     }
2300                 }
2301             }
2302             SP--;
2303             SETi(value);
2304             RETURN;
2305         }
2306     }
2307 #endif
2308     {
2309       dPOPTOPnnrl_nomg;
2310       I32 value;
2311
2312 #ifdef Perl_isnan
2313       if (Perl_isnan(left) || Perl_isnan(right)) {
2314           SETs(&PL_sv_undef);
2315           RETURN;
2316        }
2317       value = (left > right) - (left < right);
2318 #else
2319       if (left == right)
2320         value = 0;
2321       else if (left < right)
2322         value = -1;
2323       else if (left > right)
2324         value = 1;
2325       else {
2326         SETs(&PL_sv_undef);
2327         RETURN;
2328       }
2329 #endif
2330       SETi(value);
2331       RETURN;
2332     }
2333 }
2334
2335 PP(pp_sle)
2336 {
2337     dVAR; dSP;
2338
2339     int amg_type = sle_amg;
2340     int multiplier = 1;
2341     int rhs = 1;
2342
2343     switch (PL_op->op_type) {
2344     case OP_SLT:
2345         amg_type = slt_amg;
2346         /* cmp < 0 */
2347         rhs = 0;
2348         break;
2349     case OP_SGT:
2350         amg_type = sgt_amg;
2351         /* cmp > 0 */
2352         multiplier = -1;
2353         rhs = 0;
2354         break;
2355     case OP_SGE:
2356         amg_type = sge_amg;
2357         /* cmp >= 0 */
2358         multiplier = -1;
2359         break;
2360     }
2361
2362     tryAMAGICbin_MG(amg_type, AMGf_set);
2363     {
2364       dPOPTOPssrl;
2365       const int cmp = (IN_LOCALE_RUNTIME
2366                  ? sv_cmp_locale_flags(left, right, 0)
2367                  : sv_cmp_flags(left, right, 0));
2368       SETs(boolSV(cmp * multiplier < rhs));
2369       RETURN;
2370     }
2371 }
2372
2373 PP(pp_seq)
2374 {
2375     dVAR; dSP;
2376     tryAMAGICbin_MG(seq_amg, AMGf_set);
2377     {
2378       dPOPTOPssrl;
2379       SETs(boolSV(sv_eq_flags(left, right, 0)));
2380       RETURN;
2381     }
2382 }
2383
2384 PP(pp_sne)
2385 {
2386     dVAR; dSP;
2387     tryAMAGICbin_MG(sne_amg, AMGf_set);
2388     {
2389       dPOPTOPssrl;
2390       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2391       RETURN;
2392     }
2393 }
2394
2395 PP(pp_scmp)
2396 {
2397     dVAR; dSP; dTARGET;
2398     tryAMAGICbin_MG(scmp_amg, 0);
2399     {
2400       dPOPTOPssrl;
2401       const int cmp = (IN_LOCALE_RUNTIME
2402                  ? sv_cmp_locale_flags(left, right, 0)
2403                  : sv_cmp_flags(left, right, 0));
2404       SETi( cmp );
2405       RETURN;
2406     }
2407 }
2408
2409 PP(pp_bit_and)
2410 {
2411     dVAR; dSP; dATARGET;
2412     tryAMAGICbin_MG(band_amg, AMGf_assign);
2413     {
2414       dPOPTOPssrl;
2415       if (SvNIOKp(left) || SvNIOKp(right)) {
2416         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2417         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2418         if (PL_op->op_private & HINT_INTEGER) {
2419           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2420           SETi(i);
2421         }
2422         else {
2423           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2424           SETu(u);
2425         }
2426         if (left_ro_nonnum)  SvNIOK_off(left);
2427         if (right_ro_nonnum) SvNIOK_off(right);
2428       }
2429       else {
2430         do_vop(PL_op->op_type, TARG, left, right);
2431         SETTARG;
2432       }
2433       RETURN;
2434     }
2435 }
2436
2437 PP(pp_bit_or)
2438 {
2439     dVAR; dSP; dATARGET;
2440     const int op_type = PL_op->op_type;
2441
2442     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2443     {
2444       dPOPTOPssrl;
2445       if (SvNIOKp(left) || SvNIOKp(right)) {
2446         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2447         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2448         if (PL_op->op_private & HINT_INTEGER) {
2449           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2450           const IV r = SvIV_nomg(right);
2451           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2452           SETi(result);
2453         }
2454         else {
2455           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2456           const UV r = SvUV_nomg(right);
2457           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2458           SETu(result);
2459         }
2460         if (left_ro_nonnum)  SvNIOK_off(left);
2461         if (right_ro_nonnum) SvNIOK_off(right);
2462       }
2463       else {
2464         do_vop(op_type, TARG, left, right);
2465         SETTARG;
2466       }
2467       RETURN;
2468     }
2469 }
2470
2471 PP(pp_negate)
2472 {
2473     dVAR; dSP; dTARGET;
2474     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2475     {
2476         SV * const sv = TOPs;
2477         const int flags = SvFLAGS(sv);
2478
2479         if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2480            SvIV_please( sv );
2481         }
2482
2483         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2484             /* It's publicly an integer, or privately an integer-not-float */
2485         oops_its_an_int:
2486             if (SvIsUV(sv)) {
2487                 if (SvIVX(sv) == IV_MIN) {
2488                     /* 2s complement assumption. */
2489                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2490                     RETURN;
2491                 }
2492                 else if (SvUVX(sv) <= IV_MAX) {
2493                     SETi(-SvIVX(sv));
2494                     RETURN;
2495                 }
2496             }
2497             else if (SvIVX(sv) != IV_MIN) {
2498                 SETi(-SvIVX(sv));
2499                 RETURN;
2500             }
2501 #ifdef PERL_PRESERVE_IVUV
2502             else {
2503                 SETu((UV)IV_MIN);
2504                 RETURN;
2505             }
2506 #endif
2507         }
2508         if (SvNIOKp(sv))
2509             SETn(-SvNV_nomg(sv));
2510         else if (SvPOKp(sv)) {
2511             STRLEN len;
2512             const char * const s = SvPV_nomg_const(sv, len);
2513             if (isIDFIRST(*s)) {
2514                 sv_setpvs(TARG, "-");
2515                 sv_catsv(TARG, sv);
2516             }
2517             else if (*s == '+' || *s == '-') {
2518                 sv_setsv_nomg(TARG, sv);
2519                 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2520             }
2521             else if (DO_UTF8(sv)) {
2522                 SvIV_please_nomg(sv);
2523                 if (SvIOK(sv))
2524                     goto oops_its_an_int;
2525                 if (SvNOK(sv))
2526                     sv_setnv(TARG, -SvNV_nomg(sv));
2527                 else {
2528                     sv_setpvs(TARG, "-");
2529                     sv_catsv(TARG, sv);
2530                 }
2531             }
2532             else {
2533                 SvIV_please_nomg(sv);
2534                 if (SvIOK(sv))
2535                   goto oops_its_an_int;
2536                 sv_setnv(TARG, -SvNV_nomg(sv));
2537             }
2538             SETTARG;
2539         }
2540         else
2541             SETn(-SvNV_nomg(sv));
2542     }
2543     RETURN;
2544 }
2545
2546 PP(pp_not)
2547 {
2548     dVAR; dSP;
2549     tryAMAGICun_MG(not_amg, AMGf_set);
2550     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2551     return NORMAL;
2552 }
2553
2554 PP(pp_complement)
2555 {
2556     dVAR; dSP; dTARGET;
2557     tryAMAGICun_MG(compl_amg, 0);
2558     {
2559       dTOPss;
2560       if (SvNIOKp(sv)) {
2561         if (PL_op->op_private & HINT_INTEGER) {
2562           const IV i = ~SvIV_nomg(sv);
2563           SETi(i);
2564         }
2565         else {
2566           const UV u = ~SvUV_nomg(sv);
2567           SETu(u);
2568         }
2569       }
2570       else {
2571         register U8 *tmps;
2572         register I32 anum;
2573         STRLEN len;
2574
2575         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2576         sv_setsv_nomg(TARG, sv);
2577         tmps = (U8*)SvPV_force_nomg(TARG, len);
2578         anum = len;
2579         if (SvUTF8(TARG)) {
2580           /* Calculate exact length, let's not estimate. */
2581           STRLEN targlen = 0;
2582           STRLEN l;
2583           UV nchar = 0;
2584           UV nwide = 0;
2585           U8 * const send = tmps + len;
2586           U8 * const origtmps = tmps;
2587           const UV utf8flags = UTF8_ALLOW_ANYUV;
2588
2589           while (tmps < send) {
2590             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2591             tmps += l;
2592             targlen += UNISKIP(~c);
2593             nchar++;
2594             if (c > 0xff)
2595                 nwide++;
2596           }
2597
2598           /* Now rewind strings and write them. */
2599           tmps = origtmps;
2600
2601           if (nwide) {
2602               U8 *result;
2603               U8 *p;
2604
2605               Newx(result, targlen + 1, U8);
2606               p = result;
2607               while (tmps < send) {
2608                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2609                   tmps += l;
2610                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2611               }
2612               *p = '\0';
2613               sv_usepvn_flags(TARG, (char*)result, targlen,
2614                               SV_HAS_TRAILING_NUL);
2615               SvUTF8_on(TARG);
2616           }
2617           else {
2618               U8 *result;
2619               U8 *p;
2620
2621               Newx(result, nchar + 1, U8);
2622               p = result;
2623               while (tmps < send) {
2624                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2625                   tmps += l;
2626                   *p++ = ~c;
2627               }
2628               *p = '\0';
2629               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2630               SvUTF8_off(TARG);
2631           }
2632           SETTARG;
2633           RETURN;
2634         }
2635 #ifdef LIBERAL
2636         {
2637             register long *tmpl;
2638             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2639                 *tmps = ~*tmps;
2640             tmpl = (long*)tmps;
2641             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2642                 *tmpl = ~*tmpl;
2643             tmps = (U8*)tmpl;
2644         }
2645 #endif
2646         for ( ; anum > 0; anum--, tmps++)
2647             *tmps = ~*tmps;
2648         SETTARG;
2649       }
2650       RETURN;
2651     }
2652 }
2653
2654 /* integer versions of some of the above */
2655
2656 PP(pp_i_multiply)
2657 {
2658     dVAR; dSP; dATARGET;
2659     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2660     {
2661       dPOPTOPiirl_nomg;
2662       SETi( left * right );
2663       RETURN;
2664     }
2665 }
2666
2667 PP(pp_i_divide)
2668 {
2669     IV num;
2670     dVAR; dSP; dATARGET;
2671     tryAMAGICbin_MG(div_amg, AMGf_assign);
2672     {
2673       dPOPTOPssrl;
2674       IV value = SvIV_nomg(right);
2675       if (value == 0)
2676           DIE(aTHX_ "Illegal division by zero");
2677       num = SvIV_nomg(left);
2678
2679       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2680       if (value == -1)
2681           value = - num;
2682       else
2683           value = num / value;
2684       SETi(value);
2685       RETURN;
2686     }
2687 }
2688
2689 #if defined(__GLIBC__) && IVSIZE == 8
2690 STATIC
2691 PP(pp_i_modulo_0)
2692 #else
2693 PP(pp_i_modulo)
2694 #endif
2695 {
2696      /* This is the vanilla old i_modulo. */
2697      dVAR; dSP; dATARGET;
2698      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2699      {
2700           dPOPTOPiirl_nomg;
2701           if (!right)
2702                DIE(aTHX_ "Illegal modulus zero");
2703           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2704           if (right == -1)
2705               SETi( 0 );
2706           else
2707               SETi( left % right );
2708           RETURN;
2709      }
2710 }
2711
2712 #if defined(__GLIBC__) && IVSIZE == 8
2713 STATIC
2714 PP(pp_i_modulo_1)
2715
2716 {
2717      /* This is the i_modulo with the workaround for the _moddi3 bug
2718       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2719       * See below for pp_i_modulo. */
2720      dVAR; dSP; dATARGET;
2721      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2722      {
2723           dPOPTOPiirl_nomg;
2724           if (!right)
2725                DIE(aTHX_ "Illegal modulus zero");
2726           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2727           if (right == -1)
2728               SETi( 0 );
2729           else
2730               SETi( left % PERL_ABS(right) );
2731           RETURN;
2732      }
2733 }
2734
2735 PP(pp_i_modulo)
2736 {
2737      dVAR; dSP; dATARGET;
2738      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2739      {
2740           dPOPTOPiirl_nomg;
2741           if (!right)
2742                DIE(aTHX_ "Illegal modulus zero");
2743           /* The assumption is to use hereafter the old vanilla version... */
2744           PL_op->op_ppaddr =
2745                PL_ppaddr[OP_I_MODULO] =
2746                    Perl_pp_i_modulo_0;
2747           /* .. but if we have glibc, we might have a buggy _moddi3
2748            * (at least glicb 2.2.5 is known to have this bug), in other
2749            * words our integer modulus with negative quad as the second
2750            * argument might be broken.  Test for this and re-patch the
2751            * opcode dispatch table if that is the case, remembering to
2752            * also apply the workaround so that this first round works
2753            * right, too.  See [perl #9402] for more information. */
2754           {
2755                IV l =   3;
2756                IV r = -10;
2757                /* Cannot do this check with inlined IV constants since
2758                 * that seems to work correctly even with the buggy glibc. */
2759                if (l % r == -3) {
2760                     /* Yikes, we have the bug.
2761                      * Patch in the workaround version. */
2762                     PL_op->op_ppaddr =
2763                          PL_ppaddr[OP_I_MODULO] =
2764                              &Perl_pp_i_modulo_1;
2765                     /* Make certain we work right this time, too. */
2766                     right = PERL_ABS(right);
2767                }
2768           }
2769           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2770           if (right == -1)
2771               SETi( 0 );
2772           else
2773               SETi( left % right );
2774           RETURN;
2775      }
2776 }
2777 #endif
2778
2779 PP(pp_i_add)
2780 {
2781     dVAR; dSP; dATARGET;
2782     tryAMAGICbin_MG(add_amg, AMGf_assign);
2783     {
2784       dPOPTOPiirl_ul_nomg;
2785       SETi( left + right );
2786       RETURN;
2787     }
2788 }
2789
2790 PP(pp_i_subtract)
2791 {
2792     dVAR; dSP; dATARGET;
2793     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2794     {
2795       dPOPTOPiirl_ul_nomg;
2796       SETi( left - right );
2797       RETURN;
2798     }
2799 }
2800
2801 PP(pp_i_lt)
2802 {
2803     dVAR; dSP;
2804     tryAMAGICbin_MG(lt_amg, AMGf_set);
2805     {
2806       dPOPTOPiirl_nomg;
2807       SETs(boolSV(left < right));
2808       RETURN;
2809     }
2810 }
2811
2812 PP(pp_i_gt)
2813 {
2814     dVAR; dSP;
2815     tryAMAGICbin_MG(gt_amg, AMGf_set);
2816     {
2817       dPOPTOPiirl_nomg;
2818       SETs(boolSV(left > right));
2819       RETURN;
2820     }
2821 }
2822
2823 PP(pp_i_le)
2824 {
2825     dVAR; dSP;
2826     tryAMAGICbin_MG(le_amg, AMGf_set);
2827     {
2828       dPOPTOPiirl_nomg;
2829       SETs(boolSV(left <= right));
2830       RETURN;
2831     }
2832 }
2833
2834 PP(pp_i_ge)
2835 {
2836     dVAR; dSP;
2837     tryAMAGICbin_MG(ge_amg, AMGf_set);
2838     {
2839       dPOPTOPiirl_nomg;
2840       SETs(boolSV(left >= right));
2841       RETURN;
2842     }
2843 }
2844
2845 PP(pp_i_eq)
2846 {
2847     dVAR; dSP;
2848     tryAMAGICbin_MG(eq_amg, AMGf_set);
2849     {
2850       dPOPTOPiirl_nomg;
2851       SETs(boolSV(left == right));
2852       RETURN;
2853     }
2854 }
2855
2856 PP(pp_i_ne)
2857 {
2858     dVAR; dSP;
2859     tryAMAGICbin_MG(ne_amg, AMGf_set);
2860     {
2861       dPOPTOPiirl_nomg;
2862       SETs(boolSV(left != right));
2863       RETURN;
2864     }
2865 }
2866
2867 PP(pp_i_ncmp)
2868 {
2869     dVAR; dSP; dTARGET;
2870     tryAMAGICbin_MG(ncmp_amg, 0);
2871     {
2872       dPOPTOPiirl_nomg;
2873       I32 value;
2874
2875       if (left > right)
2876         value = 1;
2877       else if (left < right)
2878         value = -1;
2879       else
2880         value = 0;
2881       SETi(value);
2882       RETURN;
2883     }
2884 }
2885
2886 PP(pp_i_negate)
2887 {
2888     dVAR; dSP; dTARGET;
2889     tryAMAGICun_MG(neg_amg, 0);
2890     {
2891         SV * const sv = TOPs;
2892         IV const i = SvIV_nomg(sv);
2893         SETi(-i);
2894         RETURN;
2895     }
2896 }
2897
2898 /* High falutin' math. */
2899
2900 PP(pp_atan2)
2901 {
2902     dVAR; dSP; dTARGET;
2903     tryAMAGICbin_MG(atan2_amg, 0);
2904     {
2905       dPOPTOPnnrl_nomg;
2906       SETn(Perl_atan2(left, right));
2907       RETURN;
2908     }
2909 }
2910
2911 PP(pp_sin)
2912 {
2913     dVAR; dSP; dTARGET;
2914     int amg_type = sin_amg;
2915     const char *neg_report = NULL;
2916     NV (*func)(NV) = Perl_sin;
2917     const int op_type = PL_op->op_type;
2918
2919     switch (op_type) {
2920     case OP_COS:
2921         amg_type = cos_amg;
2922         func = Perl_cos;
2923         break;
2924     case OP_EXP:
2925         amg_type = exp_amg;
2926         func = Perl_exp;
2927         break;
2928     case OP_LOG:
2929         amg_type = log_amg;
2930         func = Perl_log;
2931         neg_report = "log";
2932         break;
2933     case OP_SQRT:
2934         amg_type = sqrt_amg;
2935         func = Perl_sqrt;
2936         neg_report = "sqrt";
2937         break;
2938     }
2939
2940
2941     tryAMAGICun_MG(amg_type, 0);
2942     {
2943       SV * const arg = POPs;
2944       const NV value = SvNV_nomg(arg);
2945       if (neg_report) {
2946           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2947               SET_NUMERIC_STANDARD();
2948               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2949           }
2950       }
2951       XPUSHn(func(value));
2952       RETURN;
2953     }
2954 }
2955
2956 /* Support Configure command-line overrides for rand() functions.
2957    After 5.005, perhaps we should replace this by Configure support
2958    for drand48(), random(), or rand().  For 5.005, though, maintain
2959    compatibility by calling rand() but allow the user to override it.
2960    See INSTALL for details.  --Andy Dougherty  15 July 1998
2961 */
2962 /* Now it's after 5.005, and Configure supports drand48() and random(),
2963    in addition to rand().  So the overrides should not be needed any more.
2964    --Jarkko Hietaniemi  27 September 1998
2965  */
2966
2967 #ifndef HAS_DRAND48_PROTO
2968 extern double drand48 (void);
2969 #endif
2970
2971 PP(pp_rand)
2972 {
2973     dVAR; dSP; dTARGET;
2974     NV value;
2975     if (MAXARG < 1)
2976         value = 1.0;
2977     else
2978         value = POPn;
2979     if (value == 0.0)
2980         value = 1.0;
2981     if (!PL_srand_called) {
2982         (void)seedDrand01((Rand_seed_t)seed());
2983         PL_srand_called = TRUE;
2984     }
2985     value *= Drand01();
2986     XPUSHn(value);
2987     RETURN;
2988 }
2989
2990 PP(pp_srand)
2991 {
2992     dVAR; dSP; dTARGET;
2993     const UV anum = (MAXARG < 1) ? seed() : POPu;
2994     (void)seedDrand01((Rand_seed_t)anum);
2995     PL_srand_called = TRUE;
2996     if (anum)
2997         XPUSHu(anum);
2998     else {
2999         /* Historically srand always returned true. We can avoid breaking
3000            that like this:  */
3001         sv_setpvs(TARG, "0 but true");
3002         XPUSHTARG;
3003     }
3004     RETURN;
3005 }
3006
3007 PP(pp_int)
3008 {
3009     dVAR; dSP; dTARGET;
3010     tryAMAGICun_MG(int_amg, AMGf_numeric);
3011     {
3012       SV * const sv = TOPs;
3013       const IV iv = SvIV_nomg(sv);
3014       /* XXX it's arguable that compiler casting to IV might be subtly
3015          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3016          else preferring IV has introduced a subtle behaviour change bug. OTOH
3017          relying on floating point to be accurate is a bug.  */
3018
3019       if (!SvOK(sv)) {
3020         SETu(0);
3021       }
3022       else if (SvIOK(sv)) {
3023         if (SvIsUV(sv))
3024             SETu(SvUV_nomg(sv));
3025         else
3026             SETi(iv);
3027       }
3028       else {
3029           const NV value = SvNV_nomg(sv);
3030           if (value >= 0.0) {
3031               if (value < (NV)UV_MAX + 0.5) {
3032                   SETu(U_V(value));
3033               } else {
3034                   SETn(Perl_floor(value));
3035               }
3036           }
3037           else {
3038               if (value > (NV)IV_MIN - 0.5) {
3039                   SETi(I_V(value));
3040               } else {
3041                   SETn(Perl_ceil(value));
3042               }
3043           }
3044       }
3045     }
3046     RETURN;
3047 }
3048
3049 PP(pp_abs)
3050 {
3051     dVAR; dSP; dTARGET;
3052     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3053     {
3054       SV * const sv = TOPs;
3055       /* This will cache the NV value if string isn't actually integer  */
3056       const IV iv = SvIV_nomg(sv);
3057
3058       if (!SvOK(sv)) {
3059         SETu(0);
3060       }
3061       else if (SvIOK(sv)) {
3062         /* IVX is precise  */
3063         if (SvIsUV(sv)) {
3064           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3065         } else {
3066           if (iv >= 0) {
3067             SETi(iv);
3068           } else {
3069             if (iv != IV_MIN) {
3070               SETi(-iv);
3071             } else {
3072               /* 2s complement assumption. Also, not really needed as
3073                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3074               SETu(IV_MIN);
3075             }
3076           }
3077         }
3078       } else{
3079         const NV value = SvNV_nomg(sv);
3080         if (value < 0.0)
3081           SETn(-value);
3082         else
3083           SETn(value);
3084       }
3085     }
3086     RETURN;
3087 }
3088
3089 PP(pp_oct)
3090 {
3091     dVAR; dSP; dTARGET;
3092     const char *tmps;
3093     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3094     STRLEN len;
3095     NV result_nv;
3096     UV result_uv;
3097     SV* const sv = POPs;
3098
3099     tmps = (SvPV_const(sv, len));
3100     if (DO_UTF8(sv)) {
3101          /* If Unicode, try to downgrade
3102           * If not possible, croak. */
3103          SV* const tsv = sv_2mortal(newSVsv(sv));
3104
3105          SvUTF8_on(tsv);
3106          sv_utf8_downgrade(tsv, FALSE);
3107          tmps = SvPV_const(tsv, len);
3108     }
3109     if (PL_op->op_type == OP_HEX)
3110         goto hex;
3111
3112     while (*tmps && len && isSPACE(*tmps))
3113         tmps++, len--;
3114     if (*tmps == '0')
3115         tmps++, len--;
3116     if (*tmps == 'x' || *tmps == 'X') {
3117     hex:
3118         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3119     }
3120     else if (*tmps == 'b' || *tmps == 'B')
3121         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3122     else
3123         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3124
3125     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3126         XPUSHn(result_nv);
3127     }
3128     else {
3129         XPUSHu(result_uv);
3130     }
3131     RETURN;
3132 }
3133
3134 /* String stuff. */
3135
3136 PP(pp_length)
3137 {
3138     dVAR; dSP; dTARGET;
3139     SV * const sv = TOPs;
3140
3141     if (SvGAMAGIC(sv)) {
3142         /* For an overloaded or magic scalar, we can't know in advance if
3143            it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3144            it likes to cache the length. Maybe that should be a documented
3145            feature of it.
3146         */
3147         STRLEN len;
3148         const char *const p
3149             = sv_2pv_flags(sv, &len,
3150                            SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3151
3152         if (!p) {
3153             sv_setsv(TARG, &PL_sv_undef);
3154             SETTARG;
3155         }
3156         else if (DO_UTF8(sv)) {
3157             SETi(utf8_length((U8*)p, (U8*)p + len));
3158         }
3159         else
3160             SETi(len);
3161     } else if (SvOK(sv)) {
3162         /* Neither magic nor overloaded.  */
3163         if (DO_UTF8(sv))
3164             SETi(sv_len_utf8(sv));
3165         else
3166             SETi(sv_len(sv));
3167     } else {
3168         sv_setsv_nomg(TARG, &PL_sv_undef);
3169         SETTARG;
3170     }
3171     RETURN;
3172 }
3173
3174 PP(pp_substr)
3175 {
3176     dVAR; dSP; dTARGET;
3177     SV *sv;
3178     STRLEN curlen;
3179     STRLEN utf8_curlen;
3180     SV *   pos_sv;
3181     IV     pos1_iv;
3182     int    pos1_is_uv;
3183     IV     pos2_iv;
3184     int    pos2_is_uv;
3185     SV *   len_sv;
3186     IV     len_iv = 0;
3187     int    len_is_uv = 1;
3188     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3189     const char *tmps;
3190     const IV arybase = CopARYBASE_get(PL_curcop);
3191     SV *repl_sv = NULL;
3192     const char *repl = NULL;
3193     STRLEN repl_len;
3194     const int num_args = PL_op->op_private & 7;
3195     bool repl_need_utf8_upgrade = FALSE;
3196     bool repl_is_utf8 = FALSE;
3197
3198     if (num_args > 2) {
3199         if (num_args > 3) {
3200             repl_sv = POPs;
3201             repl = SvPV_const(repl_sv, repl_len);
3202             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3203         }
3204         len_sv    = POPs;
3205         len_iv    = SvIV(len_sv);
3206         len_is_uv = SvIOK_UV(len_sv);
3207     }
3208     pos_sv     = POPs;
3209     pos1_iv    = SvIV(pos_sv);
3210     pos1_is_uv = SvIOK_UV(pos_sv);
3211     sv = POPs;
3212     PUTBACK;
3213     if (repl_sv) {
3214         if (repl_is_utf8) {
3215             if (!DO_UTF8(sv))
3216                 sv_utf8_upgrade(sv);
3217         }
3218         else if (DO_UTF8(sv))
3219             repl_need_utf8_upgrade = TRUE;
3220     }
3221     tmps = SvPV_const(sv, curlen);
3222     if (DO_UTF8(sv)) {
3223         utf8_curlen = sv_len_utf8(sv);
3224         if (utf8_curlen == curlen)
3225             utf8_curlen = 0;
3226         else
3227             curlen = utf8_curlen;
3228     }
3229     else
3230         utf8_curlen = 0;
3231
3232     if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3233         UV pos1_uv = pos1_iv-arybase;
3234         /* Overflow can occur when $[ < 0 */
3235         if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3236             goto bound_fail;
3237         pos1_iv = pos1_uv;
3238         pos1_is_uv = 1;
3239     }
3240     else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3241         goto bound_fail;  /* $[=3; substr($_,2,...) */
3242     }
3243     else { /* pos < $[ */
3244         if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3245             pos1_iv = curlen;
3246             pos1_is_uv = 1;
3247         } else {
3248             if (curlen) {
3249                 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3250                 pos1_iv += curlen;
3251            }
3252         }
3253     }
3254     if (pos1_is_uv || pos1_iv > 0) {
3255         if ((UV)pos1_iv > curlen)
3256             goto bound_fail;
3257     }
3258
3259     if (num_args > 2) {
3260         if (!len_is_uv && len_iv < 0) {
3261             pos2_iv = curlen + len_iv;
3262             if (curlen)
3263                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3264             else
3265                 pos2_is_uv = 0;
3266         } else {  /* len_iv >= 0 */
3267             if (!pos1_is_uv && pos1_iv < 0) {
3268                 pos2_iv = pos1_iv + len_iv;
3269                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3270             } else {
3271                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3272                     pos2_iv = curlen;
3273                 else
3274                     pos2_iv = pos1_iv+len_iv;
3275                 pos2_is_uv = 1;
3276             }
3277         }
3278     }
3279     else {
3280         pos2_iv = curlen;
3281         pos2_is_uv = 1;
3282     }
3283
3284     if (!pos2_is_uv && pos2_iv < 0) {
3285         if (!pos1_is_uv && pos1_iv < 0)
3286             goto bound_fail;
3287         pos2_iv = 0;
3288     }
3289     else if (!pos1_is_uv && pos1_iv < 0)
3290         pos1_iv = 0;
3291
3292     if ((UV)pos2_iv < (UV)pos1_iv)
3293         pos2_iv = pos1_iv;
3294     if ((UV)pos2_iv > curlen)
3295         pos2_iv = curlen;
3296
3297     {
3298         /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3299         const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3300         const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3301         STRLEN byte_len = len;
3302         STRLEN byte_pos = utf8_curlen
3303             ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3304
3305         if (lvalue && !repl) {
3306             SV * ret;
3307
3308             if (!SvGMAGICAL(sv)) {
3309                 if (SvROK(sv)) {
3310                     SvPV_force_nolen(sv);
3311                     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3312                                    "Attempt to use reference as lvalue in substr");
3313                 }
3314                 if (isGV_with_GP(sv))
3315                     SvPV_force_nolen(sv);
3316                 else if (SvOK(sv))      /* is it defined ? */
3317                     (void)SvPOK_only_UTF8(sv);
3318                 else
3319                     sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3320             }
3321
3322             ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3323             sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3324             LvTYPE(ret) = 'x';
3325             LvTARG(ret) = SvREFCNT_inc_simple(sv);
3326             LvTARGOFF(ret) = pos;
3327             LvTARGLEN(ret) = len;
3328
3329             SPAGAIN;
3330             PUSHs(ret);    /* avoid SvSETMAGIC here */
3331             RETURN;
3332         }
3333
3334         SvTAINTED_off(TARG);                    /* decontaminate */
3335         SvUTF8_off(TARG);                       /* decontaminate */
3336
3337         tmps += byte_pos;
3338         sv_setpvn(TARG, tmps, byte_len);
3339 #ifdef USE_LOCALE_COLLATE
3340         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3341 #endif
3342         if (utf8_curlen)
3343             SvUTF8_on(TARG);
3344
3345         if (repl) {
3346             SV* repl_sv_copy = NULL;
3347
3348             if (repl_need_utf8_upgrade) {
3349                 repl_sv_copy = newSVsv(repl_sv);
3350                 sv_utf8_upgrade(repl_sv_copy);
3351                 repl = SvPV_const(repl_sv_copy, repl_len);
3352                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3353             }
3354             if (!SvOK(sv))
3355                 sv_setpvs(sv, "");
3356             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3357             if (repl_is_utf8)
3358                 SvUTF8_on(sv);
3359             SvREFCNT_dec(repl_sv_copy);
3360         }
3361     }
3362     SPAGAIN;
3363     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3364     RETURN;
3365
3366 bound_fail:
3367     if (lvalue || repl)
3368         Perl_croak(aTHX_ "substr outside of string");
3369     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3370     RETPUSHUNDEF;
3371 }
3372
3373 PP(pp_vec)
3374 {
3375     dVAR; dSP;
3376     register const IV size   = POPi;
3377     register const IV offset = POPi;
3378     register SV * const src = POPs;
3379     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3380     SV * ret;
3381
3382     if (lvalue) {                       /* it's an lvalue! */
3383         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3384         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3385         LvTYPE(ret) = 'v';
3386         LvTARG(ret) = SvREFCNT_inc_simple(src);
3387         LvTARGOFF(ret) = offset;
3388         LvTARGLEN(ret) = size;
3389     }
3390     else {
3391         dTARGET;
3392         SvTAINTED_off(TARG);            /* decontaminate */
3393         ret = TARG;
3394     }
3395
3396     sv_setuv(ret, do_vecget(src, offset, size));
3397     PUSHs(ret);
3398     RETURN;
3399 }
3400
3401 PP(pp_index)
3402 {
3403     dVAR; dSP; dTARGET;
3404     SV *big;
3405     SV *little;
3406     SV *temp = NULL;
3407     STRLEN biglen;
3408     STRLEN llen = 0;
3409     I32 offset;
3410     I32 retval;
3411     const char *big_p;
3412     const char *little_p;
3413     const I32 arybase = CopARYBASE_get(PL_curcop);
3414     bool big_utf8;
3415     bool little_utf8;
3416     const bool is_index = PL_op->op_type == OP_INDEX;
3417
3418     if (MAXARG >= 3) {
3419         /* arybase is in characters, like offset, so combine prior to the
3420            UTF-8 to bytes calculation.  */
3421         offset = POPi - arybase;
3422     }
3423     little = POPs;
3424     big = POPs;
3425     big_p = SvPV_const(big, biglen);
3426     little_p = SvPV_const(little, llen);
3427
3428     big_utf8 = DO_UTF8(big);
3429     little_utf8 = DO_UTF8(little);
3430     if (big_utf8 ^ little_utf8) {
3431         /* One needs to be upgraded.  */
3432         if (little_utf8 && !PL_encoding) {
3433             /* Well, maybe instead we might be able to downgrade the small
3434                string?  */
3435             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3436                                                      &little_utf8);
3437             if (little_utf8) {
3438                 /* If the large string is ISO-8859-1, and it's not possible to
3439                    convert the small string to ISO-8859-1, then there is no
3440                    way that it could be found anywhere by index.  */
3441                 retval = -1;
3442                 goto fail;
3443             }
3444
3445             /* At this point, pv is a malloc()ed string. So donate it to temp
3446                to ensure it will get free()d  */
3447             little = temp = newSV(0);
3448             sv_usepvn(temp, pv, llen);
3449             little_p = SvPVX(little);
3450         } else {
3451             temp = little_utf8
3452                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3453
3454             if (PL_encoding) {
3455                 sv_recode_to_utf8(temp, PL_encoding);
3456             } else {
3457                 sv_utf8_upgrade(temp);
3458             }
3459             if (little_utf8) {
3460                 big = temp;
3461                 big_utf8 = TRUE;
3462                 big_p = SvPV_const(big, biglen);
3463             } else {
3464                 little = temp;
3465                 little_p = SvPV_const(little, llen);
3466             }
3467         }
3468     }
3469     if (SvGAMAGIC(big)) {
3470         /* Life just becomes a lot easier if I use a temporary here.
3471            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3472            will trigger magic and overloading again, as will fbm_instr()
3473         */
3474         big = newSVpvn_flags(big_p, biglen,
3475                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3476         big_p = SvPVX(big);
3477     }
3478     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3479         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3480            warn on undef, and we've already triggered a warning with the
3481            SvPV_const some lines above. We can't remove that, as we need to
3482            call some SvPV to trigger overloading early and find out if the
3483            string is UTF-8.
3484            This is all getting to messy. The API isn't quite clean enough,
3485            because data access has side effects.
3486         */
3487         little = newSVpvn_flags(little_p, llen,
3488                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3489         little_p = SvPVX(little);
3490     }
3491
3492     if (MAXARG < 3)
3493         offset = is_index ? 0 : biglen;
3494     else {
3495         if (big_utf8 && offset > 0)
3496             sv_pos_u2b(big, &offset, 0);
3497         if (!is_index)
3498             offset += llen;
3499     }
3500     if (offset < 0)
3501         offset = 0;
3502     else if (offset > (I32)biglen)
3503         offset = biglen;
3504     if (!(little_p = is_index
3505           ? fbm_instr((unsigned char*)big_p + offset,
3506                       (unsigned char*)big_p + biglen, little, 0)
3507           : rninstr(big_p,  big_p  + offset,
3508                     little_p, little_p + llen)))
3509         retval = -1;
3510     else {
3511         retval = little_p - big_p;
3512         if (retval > 0 && big_utf8)
3513             sv_pos_b2u(big, &retval);
3514     }
3515     SvREFCNT_dec(temp);
3516  fail:
3517     PUSHi(retval + arybase);
3518     RETURN;
3519 }
3520
3521 PP(pp_sprintf)
3522 {
3523     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3524     if (SvTAINTED(MARK[1]))
3525         TAINT_PROPER("sprintf");
3526     SvTAINTED_off(TARG);
3527     do_sprintf(TARG, SP-MARK, MARK+1);
3528     TAINT_IF(SvTAINTED(TARG));
3529     SP = ORIGMARK;
3530     PUSHTARG;
3531     RETURN;
3532 }
3533
3534 PP(pp_ord)
3535 {
3536     dVAR; dSP; dTARGET;
3537
3538     SV *argsv = POPs;
3539     STRLEN len;
3540     const U8 *s = (U8*)SvPV_const(argsv, len);
3541
3542     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3543         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3544         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3545         argsv = tmpsv;
3546     }
3547
3548     XPUSHu(DO_UTF8(argsv) ?
3549            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3550            (UV)(*s & 0xff));
3551
3552     RETURN;
3553 }
3554
3555 PP(pp_chr)
3556 {
3557     dVAR; dSP; dTARGET;
3558     char *tmps;
3559     UV value;
3560
3561     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3562          ||
3563          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3564         if (IN_BYTES) {
3565             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3566         } else {
3567             (void) POPs; /* Ignore the argument value. */
3568             value = UNICODE_REPLACEMENT;
3569         }
3570     } else {
3571         value = POPu;
3572     }
3573
3574     SvUPGRADE(TARG,SVt_PV);
3575
3576     if (value > 255 && !IN_BYTES) {
3577         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3578         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3579         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3580         *tmps = '\0';
3581         (void)SvPOK_only(TARG);
3582         SvUTF8_on(TARG);
3583         XPUSHs(TARG);
3584         RETURN;
3585     }
3586
3587     SvGROW(TARG,2);
3588     SvCUR_set(TARG, 1);
3589     tmps = SvPVX(TARG);
3590     *tmps++ = (char)value;
3591     *tmps = '\0';
3592     (void)SvPOK_only(TARG);
3593
3594     if (PL_encoding && !IN_BYTES) {
3595         sv_recode_to_utf8(TARG, PL_encoding);
3596         tmps = SvPVX(TARG);
3597         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3598             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3599             SvGROW(TARG, 2);
3600             tmps = SvPVX(TARG);
3601             SvCUR_set(TARG, 1);
3602             *tmps++ = (char)value;
3603             *tmps = '\0';
3604             SvUTF8_off(TARG);
3605         }
3606     }
3607
3608     XPUSHs(TARG);
3609     RETURN;
3610 }
3611
3612 PP(pp_crypt)
3613 {
3614 #ifdef HAS_CRYPT
3615     dVAR; dSP; dTARGET;
3616     dPOPTOPssrl;
3617     STRLEN len;
3618     const char *tmps = SvPV_const(left, len);
3619
3620     if (DO_UTF8(left)) {
3621          /* If Unicode, try to downgrade.
3622           * If not possible, croak.
3623           * Yes, we made this up.  */
3624          SV* const tsv = sv_2mortal(newSVsv(left));
3625
3626          SvUTF8_on(tsv);
3627          sv_utf8_downgrade(tsv, FALSE);
3628          tmps = SvPV_const(tsv, len);
3629     }
3630 #   ifdef USE_ITHREADS
3631 #     ifdef HAS_CRYPT_R
3632     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3633       /* This should be threadsafe because in ithreads there is only
3634        * one thread per interpreter.  If this would not be true,
3635        * we would need a mutex to protect this malloc. */
3636         PL_reentrant_buffer->_crypt_struct_buffer =
3637           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3638 #if defined(__GLIBC__) || defined(__EMX__)
3639         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3640             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3641             /* work around glibc-2.2.5 bug */
3642             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3643         }
3644 #endif
3645     }
3646 #     endif /* HAS_CRYPT_R */
3647 #   endif /* USE_ITHREADS */
3648 #   ifdef FCRYPT
3649     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3650 #   else
3651     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3652 #   endif
3653     SETTARG;
3654     RETURN;
3655 #else
3656     DIE(aTHX_
3657       "The crypt() function is unimplemented due to excessive paranoia.");
3658 #endif
3659 }
3660
3661 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3662  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3663
3664 /* Both the characters below can be stored in two UTF-8 bytes.  In UTF-8 the max
3665  * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3666  * See http://www.unicode.org/unicode/reports/tr16 */
3667 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178    /* Also is title case */
3668 #define GREEK_CAPITAL_LETTER_MU 0x039C  /* Upper and title case of MICRON */
3669
3670 /* Below are several macros that generate code */
3671 /* Generates code to store a unicode codepoint c that is known to occupy
3672  * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3673 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c)                                    \
3674     STMT_START {                                                            \
3675         *(p) = UTF8_TWO_BYTE_HI(c);                                         \
3676         *((p)+1) = UTF8_TWO_BYTE_LO(c);                                     \
3677     } STMT_END
3678
3679 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3680  * available byte after the two bytes */
3681 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c)                                      \
3682     STMT_START {                                                            \
3683         *(p)++ = UTF8_TWO_BYTE_HI(c);                                       \
3684         *((p)++) = UTF8_TWO_BYTE_LO(c);                                     \
3685     } STMT_END
3686
3687 /* Generates code to store the upper case of latin1 character l which is known
3688  * to have its upper case be non-latin1 into the two bytes p and p+1.  There
3689  * are only two characters that fit this description, and this macro knows
3690  * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3691  * bytes */
3692 #define STORE_NON_LATIN1_UC(p, l)                                           \
3693 STMT_START {                                                                \
3694     if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3695         STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);  \
3696     } else { /* Must be the following letter */                                                             \
3697         STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU);           \
3698     }                                                                       \
3699 } STMT_END
3700
3701 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3702  * after the character stored */
3703 #define CAT_NON_LATIN1_UC(p, l)                                             \
3704 STMT_START {                                                                \
3705     if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3706         CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);    \
3707     } else {                                                                \
3708         CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU);             \
3709     }                                                                       \
3710 } STMT_END
3711
3712 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3713  * case of l into p and p+1.  u must be the result of toUPPER_LATIN1_MOD(l),
3714  * and must require two bytes to store it.  Advances p to point to the next
3715  * available position */
3716 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u)                                 \
3717 STMT_START {                                                                \
3718     if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3719         CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3720     } else if (l == LATIN_SMALL_LETTER_SHARP_S) {                           \
3721         *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */                \
3722     } else {/* else is one of the other two special cases */                \
3723         CAT_NON_LATIN1_UC((p), (l));                                        \
3724     }                                                                       \
3725 } STMT_END
3726
3727 PP(pp_ucfirst)
3728 {
3729     /* Actually is both lcfirst() and ucfirst().  Only the first character
3730      * changes.  This means that possibly we can change in-place, ie., just
3731      * take the source and change that one character and store it back, but not
3732      * if read-only etc, or if the length changes */
3733
3734     dVAR;
3735     dSP;
3736     SV *source = TOPs;
3737     STRLEN slen; /* slen is the byte length of the whole SV. */
3738     STRLEN need;
3739     SV *dest;
3740     bool inplace;   /* ? Convert first char only, in-place */
3741     bool doing_utf8 = FALSE;               /* ? using utf8 */
3742     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3743     const int op_type = PL_op->op_type;
3744     const U8 *s;
3745     U8 *d;
3746     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3747     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3748                      * stored as UTF-8 at s. */
3749     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3750                      * lowercased) character stored in tmpbuf.  May be either
3751                      * UTF-8 or not, but in either case is the number of bytes */
3752
3753     SvGETMAGIC(source);
3754     if (SvOK(source)) {
3755         s = (const U8*)SvPV_nomg_const(source, slen);
3756     } else {
3757         if (ckWARN(WARN_UNINITIALIZED))
3758             report_uninit(source);
3759         s = (const U8*)"";
3760         slen = 0;
3761     }
3762
3763     /* We may be able to get away with changing only the first character, in
3764      * place, but not if read-only, etc.  Later we may discover more reasons to
3765      * not convert in-place. */
3766     inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3767
3768     /* First calculate what the changed first character should be.  This affects
3769      * whether we can just swap it out, leaving the rest of the string unchanged,
3770      * or even if have to convert the dest to UTF-8 when the source isn't */
3771
3772     if (! slen) {   /* If empty */
3773         need = 1; /* still need a trailing NUL */
3774     }
3775     else if (DO_UTF8(source)) { /* Is the source utf8? */
3776         doing_utf8 = TRUE;
3777
3778 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3779  * and doesn't allow for the user to specify their own.  When code is added to
3780  * detect if there is a user-defined mapping in force here, and if so to use
3781  * that, then the code below can be compiled.  The detection would be a good
3782  * thing anyway, as currently the user-defined mappings only work on utf8
3783  * strings, and thus depend on the chosen internal storage method, which is a
3784  * bad thing */
3785 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3786         if (UTF8_IS_INVARIANT(*s)) {
3787
3788             /* An invariant source character is either ASCII or, in EBCDIC, an
3789              * ASCII equivalent or a caseless C1 control.  In both these cases,
3790              * the lower and upper cases of any character are also invariants
3791              * (and title case is the same as upper case).  So it is safe to
3792              * use the simple case change macros which avoid the overhead of
3793              * the general functions.  Note that if perl were to be extended to
3794              * do locale handling in UTF-8 strings, this wouldn't be true in,
3795              * for example, Lithuanian or Turkic.  */
3796             *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3797             tculen = ulen = 1;
3798             need = slen + 1;
3799         }
3800         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3801             U8 chr;
3802
3803             /* Similarly, if the source character isn't invariant but is in the
3804              * latin1 range (or EBCDIC equivalent thereof), we have the case
3805              * changes compiled into perl, and can avoid the overhead of the
3806              * general functions.  In this range, the characters are stored as
3807              * two UTF-8 bytes, and it so happens that any changed-case version
3808              * is also two bytes (in both ASCIIish and EBCDIC machines). */
3809             tculen = ulen = 2;
3810             need = slen + 1;
3811
3812             /* Convert the two source bytes to a single Unicode code point
3813              * value, change case and save for below */
3814             chr = UTF8_ACCUMULATE(*s, *(s+1));
3815             if (op_type == OP_LCFIRST) {    /* lower casing is easy */
3816                 U8 lower = toLOWER_LATIN1(chr);
3817                 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3818             }
3819             else {      /* ucfirst */
3820                 U8 upper = toUPPER_LATIN1_MOD(chr);
3821
3822                 /* Most of the latin1 range characters are well-behaved.  Their
3823                  * title and upper cases are the same, and are also in the
3824                  * latin1 range.  The macro above returns their upper (hence
3825                  * title) case, and all that need be done is to save the result
3826                  * for below.  However, several characters are problematic, and
3827                  * have to be handled specially.  The MOD in the macro name
3828                  * above means that these tricky characters all get mapped to
3829                  * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3830                  * This mapping saves some tests for the majority of the
3831                  * characters */
3832
3833                 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3834
3835                     /* Not tricky.  Just save it. */
3836                     STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3837                 }
3838                 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3839
3840                     /* This one is tricky because it is two characters long,
3841                      * though the UTF-8 is still two bytes, so the stored
3842                      * length doesn't change */
3843                     *tmpbuf = 'S';  /* The UTF-8 is 'Ss' */
3844                     *(tmpbuf + 1) = 's';
3845                 }
3846                 else {
3847
3848                     /* The other two have their title and upper cases the same,
3849                      * but are tricky because the changed-case characters
3850                      * aren't in the latin1 range.  They, however, do fit into
3851                      * two UTF-8 bytes */
3852                     STORE_NON_LATIN1_UC(tmpbuf, chr);
3853                 }
3854             }
3855         }
3856         else {
3857 #endif  /* end of dont want to break user-defined casing */
3858
3859             /* Here, can't short-cut the general case */
3860
3861             utf8_to_uvchr(s, &ulen);
3862             if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3863             else toLOWER_utf8(s, tmpbuf, &tculen);
3864
3865             /* we can't do in-place if the length changes.  */
3866             if (ulen != tculen) inplace = FALSE;
3867             need = slen + 1 - ulen + tculen;
3868 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3869         }
3870 #endif
3871     }
3872     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3873             * latin1 is treated as caseless.  Note that a locale takes
3874             * precedence */
3875         tculen = 1;     /* Most characters will require one byte, but this will
3876                          * need to be overridden for the tricky ones */
3877         need = slen + 1;
3878
3879         if (op_type == OP_LCFIRST) {
3880
3881             /* lower case the first letter: no trickiness for any character */
3882             *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3883                         ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3884         }
3885         /* is ucfirst() */
3886         else if (IN_LOCALE_RUNTIME) {
3887             *tmpbuf = toUPPER_LC(*s);   /* This would be a bug if any locales
3888                                          * have upper and title case different
3889                                          */
3890         }
3891         else if (! IN_UNI_8_BIT) {
3892             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3893                                          * on EBCDIC machines whatever the
3894                                          * native function does */
3895         }
3896         else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3897             *tmpbuf = toUPPER_LATIN1_MOD(*s);
3898
3899             /* tmpbuf now has the correct title case for all latin1 characters
3900              * except for the several ones that have tricky handling.  All
3901              * of these are mapped by the MOD to the letter below. */
3902             if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3903
3904                 /* The length is going to change, with all three of these, so
3905                  * can't replace just the first character */
3906                 inplace = FALSE;
3907
3908                 /* We use the original to distinguish between these tricky
3909                  * cases */
3910                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3911                     /* Two character title case 'Ss', but can remain non-UTF-8 */
3912                     need = slen + 2;
3913                     *tmpbuf = 'S';
3914                     *(tmpbuf + 1) = 's';   /* Assert: length(tmpbuf) >= 2 */
3915                     tculen = 2;
3916                 }
3917                 else {
3918
3919                     /* The other two tricky ones have their title case outside
3920                      * latin1.  It is the same as their upper case. */
3921                     doing_utf8 = TRUE;
3922                     STORE_NON_LATIN1_UC(tmpbuf, *s);
3923
3924                     /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3925                      * and their upper cases is 2. */
3926                     tculen = ulen = 2;
3927
3928                     /* The entire result will have to be in UTF-8.  Assume worst
3929                      * case sizing in conversion. (all latin1 characters occupy
3930                      * at most two bytes in utf8) */
3931                     convert_source_to_utf8 = TRUE;
3932                     need = slen * 2 + 1;
3933                 }
3934             } /* End of is one of the three special chars */
3935         } /* End of use Unicode (Latin1) semantics */
3936     } /* End of changing the case of the first character */
3937
3938     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3939      * generate the result */
3940     if (inplace) {
3941
3942         /* We can convert in place.  This means we change just the first
3943          * character without disturbing the rest; no need to grow */
3944         dest = source;
3945         s = d = (U8*)SvPV_force_nomg(source, slen);
3946     } else {
3947         dTARGET;
3948
3949         dest = TARG;
3950
3951         /* Here, we can't convert in place; we earlier calculated how much
3952          * space we will need, so grow to accommodate that */
3953         SvUPGRADE(dest, SVt_PV);
3954         d = (U8*)SvGROW(dest, need);
3955         (void)SvPOK_only(dest);
3956
3957         SETs(dest);
3958     }
3959
3960     if (doing_utf8) {
3961         if (! inplace) {
3962             if (! convert_source_to_utf8) {
3963
3964                 /* Here  both source and dest are in UTF-8, but have to create
3965                  * the entire output.  We initialize the result to be the
3966                  * title/lower cased first character, and then append the rest
3967                  * of the string. */
3968                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3969                 if (slen > ulen) {
3970                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3971                 }
3972             }
3973             else {
3974                 const U8 *const send = s + slen;
3975
3976                 /* Here the dest needs to be in UTF-8, but the source isn't,
3977                  * except we earlier UTF-8'd the first character of the source
3978                  * into tmpbuf.  First put that into dest, and then append the
3979                  * rest of the source, converting it to UTF-8 as we go. */
3980
3981                 /* Assert tculen is 2 here because the only two characters that
3982                  * get to this part of the code have 2-byte UTF-8 equivalents */
3983                 *d++ = *tmpbuf;
3984                 *d++ = *(tmpbuf + 1);
3985                 s++;    /* We have just processed the 1st char */
3986
3987                 for (; s < send; s++) {
3988                     d = uvchr_to_utf8(d, *s);
3989                 }
3990                 *d = '\0';
3991                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3992             }
3993             SvUTF8_on(dest);
3994         }
3995         else {   /* in-place UTF-8.  Just overwrite the first character */
3996             Copy(tmpbuf, d, tculen, U8);
3997             SvCUR_set(dest, need - 1);
3998         }
3999     }
4000     else {  /* Neither source nor dest are in or need to be UTF-8 */
4001         if (slen) {
4002             if (IN_LOCALE_RUNTIME) {
4003                 TAINT;
4004                 SvTAINTED_on(dest);
4005             }
4006             if (inplace) {  /* in-place, only need to change the 1st char */
4007                 *d = *tmpbuf;
4008             }
4009             else {      /* Not in-place */
4010
4011                 /* Copy the case-changed character(s) from tmpbuf */
4012                 Copy(tmpbuf, d, tculen, U8);
4013                 d += tculen - 1; /* Code below expects d to point to final
4014                                   * character stored */
4015             }
4016         }
4017         else {  /* empty source */
4018             /* See bug #39028: Don't taint if empty  */
4019             *d = *s;
4020         }
4021
4022         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4023          * the destination to retain that flag */
4024         if (SvUTF8(source))
4025             SvUTF8_on(dest);
4026
4027         if (!inplace) { /* Finish the rest of the string, unchanged */
4028             /* This will copy the trailing NUL  */
4029             Copy(s + 1, d + 1, slen, U8);
4030             SvCUR_set(dest, need - 1);
4031         }
4032     }
4033     SvSETMAGIC(dest);
4034     RETURN;
4035 }
4036
4037 /* There's so much setup/teardown code common between uc and lc, I wonder if
4038    it would be worth merging the two, and just having a switch outside each
4039    of the three tight loops.  There is less and less commonality though */
4040 PP(pp_uc)
4041 {
4042     dVAR;
4043     dSP;
4044     SV *source = TOPs;
4045     STRLEN len;
4046     STRLEN min;
4047     SV *dest;
4048     const U8 *s;
4049     U8 *d;
4050
4051     SvGETMAGIC(source);
4052
4053     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4054         && SvTEMP(source) && !DO_UTF8(source)
4055         && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4056
4057         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4058          * make the loop tight, so we overwrite the source with the dest before
4059          * looking at it, and we need to look at the original source
4060          * afterwards.  There would also need to be code added to handle
4061          * switching to not in-place in midstream if we run into characters
4062          * that change the length.
4063          */
4064         dest = source;
4065         s = d = (U8*)SvPV_force_nomg(source, len);
4066         min = len + 1;
4067     } else {
4068         dTARGET;
4069
4070         dest = TARG;
4071
4072         /* The old implementation would copy source into TARG at this point.
4073            This had the side effect that if source was undef, TARG was now
4074            an undefined SV with PADTMP set, and they don't warn inside
4075            sv_2pv_flags(). However, we're now getting the PV direct from
4076            source, which doesn't have PADTMP set, so it would warn. Hence the
4077            little games.  */
4078
4079         if (SvOK(source)) {
4080             s = (const U8*)SvPV_nomg_const(source, len);
4081         } else {
4082             if (ckWARN(WARN_UNINITIALIZED))
4083                 report_uninit(source);
4084             s = (const U8*)"";
4085             len = 0;
4086         }
4087         min = len + 1;
4088
4089         SvUPGRADE(dest, SVt_PV);
4090         d = (U8*)SvGROW(dest, min);
4091         (void)SvPOK_only(dest);
4092
4093         SETs(dest);
4094     }
4095
4096     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4097        to check DO_UTF8 again here.  */
4098
4099     if (DO_UTF8(source)) {
4100         const U8 *const send = s + len;
4101         U8 tmpbuf[UTF8_MAXBYTES+1];
4102
4103         /* All occurrences of these are to be moved to follow any other marks.
4104          * This is context-dependent.  We may not be passed enough context to
4105          * move the iota subscript beyond all of them, but we do the best we can
4106          * with what we're given.  The result is always better than if we
4107          * hadn't done this.  And, the problem would only arise if we are
4108          * passed a character without all its combining marks, which would be
4109          * the caller's mistake.  The information this is based on comes from a
4110          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4111          * itself) and so can't be checked properly to see if it ever gets
4112          * revised.  But the likelihood of it changing is remote */
4113         bool in_iota_subscript = FALSE;
4114
4115         while (s < send) {
4116             if (in_iota_subscript && ! is_utf8_mark(s)) {
4117                 /* A non-mark.  Time to output the iota subscript */
4118 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4119 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4120
4121                 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4122                 in_iota_subscript = FALSE;
4123             }
4124
4125
4126 /* See comments at the first instance in this file of this ifdef */
4127 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4128
4129             /* If the UTF-8 character is invariant, then it is in the range
4130              * known by the standard macro; result is only one byte long */
4131             if (UTF8_IS_INVARIANT(*s)) {
4132                 *d++ = toUPPER(*s);
4133                 s++;
4134             }
4135             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4136
4137                 /* Likewise, if it fits in a byte, its case change is in our
4138                  * table */
4139                 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4140                 U8 upper = toUPPER_LATIN1_MOD(orig);
4141                 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4142                 s += 2;
4143             }
4144             else {
4145 #else
4146             {
4147 #endif
4148
4149                 /* Otherwise, need the general UTF-8 case.  Get the changed
4150                  * case value and copy it to the output buffer */
4151
4152                 const STRLEN u = UTF8SKIP(s);
4153                 STRLEN ulen;
4154
4155                 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4156                 if (uv == GREEK_CAPITAL_LETTER_IOTA
4157                     && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4158                 {
4159                     in_iota_subscript = TRUE;
4160                 }
4161                 else {
4162                     if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4163                         /* If the eventually required minimum size outgrows
4164                          * the available space, we need to grow. */
4165                         const UV o = d - (U8*)SvPVX_const(dest);
4166
4167                         /* If someone uppercases one million U+03B0s we
4168                          * SvGROW() one million times.  Or we could try
4169                          * guessing how much to allocate without allocating too
4170                          * much.  Such is life.  See corresponding comment in
4171                          * lc code for another option */
4172                         SvGROW(dest, min);
4173                         d = (U8*)SvPVX(dest) + o;
4174                     }
4175                     Copy(tmpbuf, d, ulen, U8);
4176                     d += ulen;
4177                 }
4178                 s += u;
4179             }
4180         }
4181         if (in_iota_subscript) {
4182             CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4183         }
4184         SvUTF8_on(dest);
4185         *d = '\0';
4186         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4187     }
4188     else {      /* Not UTF-8 */
4189         if (len) {
4190             const U8 *const send = s + len;
4191
4192             /* Use locale casing if in locale; regular style if not treating
4193              * latin1 as having case; otherwise the latin1 casing.  Do the
4194              * whole thing in a tight loop, for speed, */
4195             if (IN_LOCALE_RUNTIME) {
4196                 TAINT;
4197                 SvTAINTED_on(dest);
4198                 for (; s < send; d++, s++)
4199                     *d = toUPPER_LC(*s);
4200             }
4201             else if (! IN_UNI_8_BIT) {
4202                 for (; s < send; d++, s++) {
4203                     *d = toUPPER(*s);
4204                 }
4205             }
4206             else {
4207                 for (; s < send; d++, s++) {
4208                     *d = toUPPER_LATIN1_MOD(*s);
4209                     if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4210
4211                     /* The mainstream case is the tight loop above.  To avoid
4212                      * extra tests in that, all three characters that require
4213                      * special handling are mapped by the MOD to the one tested
4214                      * just above.
4215                      * Use the source to distinguish between the three cases */
4216
4217                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4218
4219                         /* uc() of this requires 2 characters, but they are
4220                          * ASCII.  If not enough room, grow the string */
4221                         if (SvLEN(dest) < ++min) {
4222                             const UV o = d - (U8*)SvPVX_const(dest);
4223                             SvGROW(dest, min);
4224                             d = (U8*)SvPVX(dest) + o;
4225                         }
4226                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4227                         continue;   /* Back to the tight loop; still in ASCII */
4228                     }
4229
4230                     /* The other two special handling characters have their
4231                      * upper cases outside the latin1 range, hence need to be
4232                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4233                      * here we are somewhere in the middle of processing a
4234                      * non-UTF-8 string, and realize that we will have to convert
4235                      * the whole thing to UTF-8.  What to do?  There are
4236                      * several possibilities.  The simplest to code is to
4237                      * convert what we have so far, set a flag, and continue on
4238                      * in the loop.  The flag would be tested each time through
4239                      * the loop, and if set, the next character would be
4240                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4241                      * to slow down the mainstream case at all for this fairly
4242                      * rare case, so I didn't want to add a test that didn't
4243                      * absolutely have to be there in the loop, besides the
4244                      * possibility that it would get too complicated for
4245                      * optimizers to deal with.  Another possibility is to just
4246                      * give up, convert the source to UTF-8, and restart the
4247                      * function that way.  Another possibility is to convert
4248                      * both what has already been processed and what is yet to
4249                      * come separately to UTF-8, then jump into the loop that
4250                      * handles UTF-8.  But the most efficient time-wise of the
4251                      * ones I could think of is what follows, and turned out to
4252                      * not require much extra code.  */
4253
4254                     /* Convert what we have so far into UTF-8, telling the
4255                      * function that we know it should be converted, and to
4256                      * allow extra space for what we haven't processed yet.
4257                      * Assume the worst case space requirements for converting
4258                      * what we haven't processed so far: that it will require
4259                      * two bytes for each remaining source character, plus the
4260                      * NUL at the end.  This may cause the string pointer to
4261                      * move, so re-find it. */
4262
4263                     len = d - (U8*)SvPVX_const(dest);
4264                     SvCUR_set(dest, len);
4265                     len = sv_utf8_upgrade_flags_grow(dest,
4266                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4267                                                 (send -s) * 2 + 1);
4268                     d = (U8*)SvPVX(dest) + len;
4269
4270                     /* And append the current character's upper case in UTF-8 */
4271                     CAT_NON_LATIN1_UC(d, *s);
4272
4273                     /* Now process the remainder of the source, converting to
4274                      * upper and UTF-8.  If a resulting byte is invariant in
4275                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4276                      * append it to the output. */
4277
4278                     s++;
4279                     for (; s < send; s++) {
4280                         U8 upper = toUPPER_LATIN1_MOD(*s);
4281                         if UTF8_IS_INVARIANT(upper) {
4282                             *d++ = upper;
4283                         }
4284                         else {
4285                             CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4286                         }
4287                     }
4288
4289                     /* Here have processed the whole source; no need to continue
4290                      * with the outer loop.  Each character has been converted
4291                      * to upper case and converted to UTF-8 */
4292
4293                     break;
4294                 } /* End of processing all latin1-style chars */
4295             } /* End of processing all chars */
4296         } /* End of source is not empty */
4297
4298         if (source != dest) {
4299             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4300             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4301         }
4302     } /* End of isn't utf8 */
4303     SvSETMAGIC(dest);
4304     RETURN;
4305 }
4306
4307 PP(pp_lc)
4308 {
4309     dVAR;
4310     dSP;
4311     SV *source = TOPs;
4312     STRLEN len;
4313     STRLEN min;
4314     SV *dest;
4315     const U8 *s;
4316     U8 *d;
4317
4318     SvGETMAGIC(source);
4319
4320     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4321         && SvTEMP(source) && !DO_UTF8(source)) {
4322
4323         /* We can convert in place, as lowercasing anything in the latin1 range
4324          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4325         dest = source;
4326         s = d = (U8*)SvPV_force_nomg(source, len);
4327         min = len + 1;
4328     } else {
4329         dTARGET;
4330
4331         dest = TARG;
4332
4333         /* The old implementation would copy source into TARG at this point.
4334            This had the side effect that if source was undef, TARG was now
4335            an undefined SV with PADTMP set, and they don't warn inside
4336            sv_2pv_flags(). However, we're now getting the PV direct from
4337            source, which doesn't have PADTMP set, so it would warn. Hence the
4338            little games.  */
4339
4340         if (SvOK(source)) {
4341             s = (const U8*)SvPV_nomg_const(source, len);
4342         } else {
4343             if (ckWARN(WARN_UNINITIALIZED))
4344                 report_uninit(source);
4345             s = (const U8*)"";
4346             len = 0;
4347         }
4348         min = len + 1;
4349
4350         SvUPGRADE(dest, SVt_PV);
4351         d = (U8*)SvGROW(dest, min);
4352         (void)SvPOK_only(dest);
4353
4354         SETs(dest);
4355     }
4356
4357     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4358        to check DO_UTF8 again here.  */
4359
4360     if (DO_UTF8(source)) {
4361         const U8 *const send = s + len;
4362         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4363
4364         while (s < send) {
4365 /* See comments at the first instance in this file of this ifdef */
4366 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4367             if (UTF8_IS_INVARIANT(*s)) {
4368
4369                 /* Invariant characters use the standard mappings compiled in.
4370                  */
4371                 *d++ = toLOWER(*s);
4372                 s++;
4373             }
4374             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4375
4376                 /* As do the ones in the Latin1 range */
4377                 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4378                 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4379                 s += 2;
4380             }
4381             else {
4382 #endif
4383                 /* Here, is utf8 not in Latin-1 range, have to go out and get
4384                  * the mappings from the tables. */
4385
4386                 const STRLEN u = UTF8SKIP(s);
4387                 STRLEN ulen;
4388
4389 #ifndef CONTEXT_DEPENDENT_CASING
4390                 toLOWER_utf8(s, tmpbuf, &ulen);
4391 #else
4392 /* This is ifdefd out because it needs more work and thought.  It isn't clear
4393  * that we should do it.
4394  * A minor objection is that this is based on a hard-coded rule from the
4395  *  Unicode standard, and may change, but this is not very likely at all.
4396  *  mktables should check and warn if it does.
4397  * More importantly, if the sigma occurs at the end of the string, we don't
4398  * have enough context to know whether it is part of a larger string or going
4399  * to be or not.  It may be that we are passed a subset of the context, via
4400  * a \U...\E, for example, and we could conceivably know the larger context if
4401  * code were changed to pass that in.  But, if the string passed in is an
4402  * intermediate result, and the user concatenates two strings together
4403  * after we have made a final sigma, that would be wrong.  If the final sigma
4404  * occurs in the middle of the string we are working on, then we know that it
4405  * should be a final sigma, but otherwise we can't be sure. */
4406
4407                 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4408
4409                 /* If the lower case is a small sigma, it may be that we need
4410                  * to change it to a final sigma.  This happens at the end of
4411                  * a word that contains more than just this character, and only
4412                  * when we started with a capital sigma. */
4413                 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4414                     s > send - len &&   /* Makes sure not the first letter */
4415                     utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4416                 ) {
4417
4418                     /* We use the algorithm in:
4419                      * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4420                      * is a CAPITAL SIGMA): If C is preceded by a sequence
4421                      * consisting of a cased letter and a case-ignorable
4422                      * sequence, and C is not followed by a sequence consisting
4423                      * of a case ignorable sequence and then a cased letter,
4424                      * then when lowercasing C, C becomes a final sigma */
4425
4426                     /* To determine if this is the end of a word, need to peek
4427                      * ahead.  Look at the next character */
4428                     const U8 *peek = s + u;
4429
4430                     /* Skip any case ignorable characters */
4431                     while (peek < send && is_utf8_case_ignorable(peek)) {
4432                         peek += UTF8SKIP(peek);
4433                     }
4434
4435                     /* If we reached the end of the string without finding any
4436                      * non-case ignorable characters, or if the next such one
4437                      * is not-cased, then we have met the conditions for it
4438                      * being a final sigma with regards to peek ahead, and so
4439                      * must do peek behind for the remaining conditions. (We
4440                      * know there is stuff behind to look at since we tested
4441                      * above that this isn't the first letter) */
4442                     if (peek >= send || ! is_utf8_cased(peek)) {
4443                         peek = utf8_hop(s, -1);
4444
4445                         /* Here are at the beginning of the first character
4446                          * before the original upper case sigma.  Keep backing
4447                          * up, skipping any case ignorable characters */
4448                         while (is_utf8_case_ignorable(peek)) {
4449                             peek = utf8_hop(peek, -1);
4450                         }
4451
4452                         /* Here peek points to the first byte of the closest
4453                          * non-case-ignorable character before the capital
4454                          * sigma.  If it is cased, then by the Unicode
4455                          * algorithm, we should use a small final sigma instead
4456                          * of what we have */
4457                         if (is_utf8_cased(peek)) {
4458                             STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4459                                         UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4460                         }
4461                     }
4462                 }
4463                 else {  /* Not a context sensitive mapping */
4464 #endif  /* End of commented out context sensitive */
4465                     if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4466
4467                         /* If the eventually required minimum size outgrows
4468                          * the available space, we need to grow. */
4469                         const UV o = d - (U8*)SvPVX_const(dest);
4470
4471                         /* If someone lowercases one million U+0130s we
4472                          * SvGROW() one million times.  Or we could try
4473                          * guessing how much to allocate without allocating too
4474                          * much.  Such is life.  Another option would be to
4475                          * grow an extra byte or two more each time we need to
4476                          * grow, which would cut down the million to 500K, with
4477                          * little waste */
4478                         SvGROW(dest, min);
4479                         d = (U8*)SvPVX(dest) + o;
4480                     }
4481 #ifdef CONTEXT_DEPENDENT_CASING
4482                 }
4483 #endif
4484                 /* Copy the newly lowercased letter to the output buffer we're
4485                  * building */
4486                 Copy(tmpbuf, d, ulen, U8);
4487                 d += ulen;
4488                 s += u;
4489 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4490             }
4491 #endif
4492         }   /* End of looping through the source string */
4493         SvUTF8_on(dest);
4494         *d = '\0';
4495         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4496     } else {    /* Not utf8 */
4497         if (len) {
4498             const U8 *const send = s + len;
4499
4500             /* Use locale casing if in locale; regular style if not treating
4501              * latin1 as having case; otherwise the latin1 casing.  Do the
4502              * whole thing in a tight loop, for speed, */
4503             if (IN_LOCALE_RUNTIME) {
4504                 TAINT;
4505                 SvTAINTED_on(dest);
4506                 for (; s < send; d++, s++)
4507                     *d = toLOWER_LC(*s);
4508             }
4509             else if (! IN_UNI_8_BIT) {
4510                 for (; s < send; d++, s++) {
4511                     *d = toLOWER(*s);
4512                 }
4513             }
4514             else {
4515                 for (; s < send; d++, s++) {
4516                     *d = toLOWER_LATIN1(*s);
4517                 }
4518             }
4519         }
4520         if (source != dest) {
4521             *d = '\0';
4522             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4523         }
4524     }
4525     SvSETMAGIC(dest);
4526     RETURN;
4527 }
4528
4529 PP(pp_quotemeta)
4530 {
4531     dVAR; dSP; dTARGET;
4532     SV * const sv = TOPs;
4533     STRLEN len;
4534     register const char *s = SvPV_const(sv,len);
4535
4536     SvUTF8_off(TARG);                           /* decontaminate */
4537     if (len) {
4538         register char *d;
4539         SvUPGRADE(TARG, SVt_PV);
4540         SvGROW(TARG, (len * 2) + 1);
4541         d = SvPVX(TARG);
4542         if (DO_UTF8(sv)) {
4543             while (len) {
4544                 if (UTF8_IS_CONTINUED(*s)) {
4545                     STRLEN ulen = UTF8SKIP(s);
4546                     if (ulen > len)
4547                         ulen = len;
4548                     len -= ulen;
4549                     while (ulen--)
4550                         *d++ = *s++;
4551                 }
4552                 else {
4553                     if (!isALNUM(*s))
4554                         *d++ = '\\';
4555                     *d++ = *s++;
4556                     len--;
4557                 }
4558             }
4559             SvUTF8_on(TARG);
4560         }
4561         else {
4562             while (len--) {
4563                 if (!isALNUM(*s))
4564                     *d++ = '\\';
4565                 *d++ = *s++;
4566             }
4567         }
4568         *d = '\0';
4569         SvCUR_set(TARG, d - SvPVX_const(TARG));
4570         (void)SvPOK_only_UTF8(TARG);
4571     }
4572     else
4573         sv_setpvn(TARG, s, len);
4574     SETTARG;
4575     RETURN;
4576 }
4577
4578 /* Arrays. */
4579
4580 PP(pp_aslice)
4581 {
4582     dVAR; dSP; dMARK; dORIGMARK;
4583     register AV *const av = MUTABLE_AV(POPs);
4584     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4585
4586     if (SvTYPE(av) == SVt_PVAV) {
4587         const I32 arybase = CopARYBASE_get(PL_curcop);
4588         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4589         bool can_preserve = FALSE;
4590
4591         if (localizing) {
4592             MAGIC *mg;
4593             HV *stash;
4594
4595             can_preserve = SvCANEXISTDELETE(av);
4596         }
4597
4598         if (lval && localizing) {
4599             register SV **svp;
4600             I32 max = -1;
4601             for (svp = MARK + 1; svp <= SP; svp++) {
4602                 const I32 elem = SvIV(*svp);
4603                 if (elem > max)
4604                     max = elem;
4605             }
4606             if (max > AvMAX(av))
4607                 av_extend(av, max);
4608         }
4609
4610         while (++MARK <= SP) {
4611             register SV **svp;
4612             I32 elem = SvIV(*MARK);
4613             bool preeminent = TRUE;
4614
4615             if (elem > 0)
4616                 elem -= arybase;
4617             if (localizing && can_preserve) {
4618                 /* If we can determine whether the element exist,
4619                  * Try to preserve the existenceness of a tied array
4620                  * element by using EXISTS and DELETE if possible.
4621                  * Fallback to FETCH and STORE otherwise. */
4622                 preeminent = av_exists(av, elem);
4623             }
4624
4625             svp = av_fetch(av, elem, lval);
4626             if (lval) {
4627                 if (!svp || *svp == &PL_sv_undef)
4628                     DIE(aTHX_ PL_no_aelem, elem);
4629                 if (localizing) {
4630                     if (preeminent)
4631                         save_aelem(av, elem, svp);
4632                     else
4633                         SAVEADELETE(av, elem);
4634                 }
4635             }
4636             *MARK = svp ? *svp : &PL_sv_undef;
4637         }
4638     }
4639     if (GIMME != G_ARRAY) {
4640         MARK = ORIGMARK;
4641         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4642         SP = MARK;
4643     }
4644     RETURN;
4645 }
4646
4647 /* Smart dereferencing for keys, values and each */
4648 PP(pp_rkeys)
4649 {
4650     dVAR;
4651     dSP;
4652     dPOPss;
4653
4654     if (!SvOK(sv))
4655         RETURN;
4656
4657     if (SvROK(sv)) {
4658         SvGETMAGIC(sv);
4659         if (SvAMAGIC(sv)) {
4660             /* N.B.: AMG macros return sv if no overloading is found */
4661             SV *maybe_hv = AMG_CALLun(sv,to_hv);
4662             SV *maybe_av = AMG_CALLun(sv,to_av);
4663             if ( maybe_hv != sv && maybe_av != sv ) {
4664                 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4665                     Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4666                         PL_op_desc[PL_op->op_type]
4667                     )
4668                 );
4669                 sv = maybe_hv;
4670             }
4671             else if ( maybe_av != sv ) {
4672                 if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) {
4673                     /* @{} overload, but underlying reftype is HV */
4674                     Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4675                         Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}",
4676                             PL_op_desc[PL_op->op_type]
4677                         )
4678                     );
4679                 }
4680                 sv = maybe_av;
4681             }
4682             else if ( maybe_hv != sv ) {
4683                 if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) {
4684                     /* %{} overload, but underlying reftype is AV */
4685                     Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4686                         Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4687                             PL_op_desc[PL_op->op_type]
4688                         )
4689                     );
4690                 }
4691                 sv = maybe_hv;
4692             }
4693         }
4694         sv = SvRV(sv);
4695     }
4696
4697     if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
4698         DIE(aTHX_ Perl_form(aTHX_ "Type of argument to %s must be hashref or arrayref",
4699             PL_op_desc[PL_op->op_type] ));
4700     }
4701
4702     /* Delegate to correct function for op type */
4703     PUSHs(sv);
4704     if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4705         return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4706     }
4707     else {
4708         return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4709     }
4710 }
4711
4712 PP(pp_aeach)
4713 {
4714     dVAR;
4715     dSP;
4716     AV *array = MUTABLE_AV(POPs);
4717     const I32 gimme = GIMME_V;
4718     IV *iterp = Perl_av_iter_p(aTHX_ array);
4719     const IV current = (*iterp)++;
4720
4721     if (current > av_len(array)) {
4722         *iterp = 0;
4723         if (gimme == G_SCALAR)
4724             RETPUSHUNDEF;
4725         else
4726             RETURN;
4727     }
4728
4729     EXTEND(SP, 2);
4730     mPUSHi(CopARYBASE_get(PL_curcop) + current);
4731     if (gimme == G_ARRAY) {
4732         SV **const element = av_fetch(array, current, 0);
4733         PUSHs(element ? *element : &PL_sv_undef);
4734     }
4735     RETURN;
4736 }
4737
4738 PP(pp_akeys)
4739 {
4740     dVAR;
4741     dSP;
4742     AV *array = MUTABLE_AV(POPs);
4743     const I32 gimme = GIMME_V;
4744
4745     *Perl_av_iter_p(aTHX_ array) = 0;
4746
4747     if (gimme == G_SCALAR) {
4748         dTARGET;
4749         PUSHi(av_len(array) + 1);
4750     }
4751     else if (gimme == G_ARRAY) {
4752         IV n = Perl_av_len(aTHX_ array);
4753         IV i = CopARYBASE_get(PL_curcop);
4754
4755         EXTEND(SP, n + 1);
4756
4757         if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4758             n += i;
4759             for (;  i <= n;  i++) {
4760                 mPUSHi(i);
4761             }
4762         }
4763         else {
4764             for (i = 0;  i <= n;  i++) {
4765                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4766                 PUSHs(elem ? *elem : &PL_sv_undef);
4767             }
4768         }
4769     }
4770     RETURN;
4771 }
4772
4773 /* Associative arrays. */
4774
4775 PP(pp_each)
4776 {
4777     dVAR;
4778     dSP;
4779     HV * hash = MUTABLE_HV(POPs);
4780     HE *entry;
4781     const I32 gimme = GIMME_V;
4782
4783     PUTBACK;
4784     /* might clobber stack_sp */
4785     entry = hv_iternext(hash);
4786     SPAGAIN;
4787
4788     EXTEND(SP, 2);
4789     if (entry) {
4790         SV* const sv = hv_iterkeysv(entry);
4791         PUSHs(sv);      /* won't clobber stack_sp */
4792         if (gimme == G_ARRAY) {
4793             SV *val;
4794             PUTBACK;
4795             /* might clobber stack_sp */
4796             val = hv_iterval(hash, entry);
4797             SPAGAIN;
4798             PUSHs(val);
4799         }
4800     }
4801     else if (gimme == G_SCALAR)
4802         RETPUSHUNDEF;
4803
4804     RETURN;
4805 }
4806
4807 STATIC OP *
4808 S_do_delete_local(pTHX)
4809 {
4810     dVAR;
4811     dSP;
4812     const I32 gimme = GIMME_V;
4813     const MAGIC *mg;
4814     HV *stash;
4815
4816     if (PL_op->op_private & OPpSLICE) {
4817         dMARK; dORIGMARK;
4818         SV * const osv = POPs;
4819         const bool tied = SvRMAGICAL(osv)
4820                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4821         const bool can_preserve = SvCANEXISTDELETE(osv)
4822                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4823         const U32 type = SvTYPE(osv);
4824         if (type == SVt_PVHV) {                 /* hash element */
4825             HV * const hv = MUTABLE_HV(osv);
4826             while (++MARK <= SP) {
4827                 SV * const keysv = *MARK;
4828                 SV *sv = NULL;
4829                 bool preeminent = TRUE;
4830                 if (can_preserve)
4831                     preeminent = hv_exists_ent(hv, keysv, 0);
4832                 if (tied) {
4833                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4834                     if (he)
4835                         sv = HeVAL(he);
4836                     else
4837                         preeminent = FALSE;
4838                 }
4839                 else {
4840                     sv = hv_delete_ent(hv, keysv, 0, 0);
4841                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4842                 }
4843                 if (preeminent) {
4844                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4845                     if (tied) {
4846                         *MARK = sv_mortalcopy(sv);
4847                         mg_clear(sv);
4848                     } else
4849                         *MARK = sv;
4850                 }
4851                 else {
4852                     SAVEHDELETE(hv, keysv);
4853                     *MARK = &PL_sv_undef;
4854                 }
4855             }
4856         }
4857         else if (type == SVt_PVAV) {                  /* array element */
4858             if (PL_op->op_flags & OPf_SPECIAL) {
4859                 AV * const av = MUTABLE_AV(osv);
4860                 while (++MARK <= SP) {
4861                     I32 idx = SvIV(*MARK);
4862                     SV *sv = NULL;
4863                     bool preeminent = TRUE;
4864                     if (can_preserve)
4865                         preeminent = av_exists(av, idx);
4866                     if (tied) {
4867                         SV **svp = av_fetch(av, idx, 1);
4868                         if (svp)
4869                             sv = *svp;
4870                         else
4871                             preeminent = FALSE;
4872                     }
4873                     else {
4874                         sv = av_delete(av, idx, 0);
4875                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4876                     }
4877                     if (preeminent) {
4878                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4879                         if (tied) {
4880                             *MARK = sv_mortalcopy(sv);
4881                             mg_clear(sv);
4882                         } else
4883                             *MARK = sv;
4884                     }
4885                     else {
4886                         SAVEADELETE(av, idx);
4887                         *MARK = &PL_sv_undef;
4888                     }
4889                 }
4890             }
4891         }
4892         else
4893             DIE(aTHX_ "Not a HASH reference");
4894         if (gimme == G_VOID)
4895             SP = ORIGMARK;
4896         else if (gimme == G_SCALAR) {
4897             MARK = ORIGMARK;
4898             if (SP > MARK)
4899                 *++MARK = *SP;
4900             else
4901                 *++MARK = &PL_sv_undef;
4902             SP = MARK;
4903         }
4904     }
4905     else {
4906         SV * const keysv = POPs;
4907         SV * const osv   = POPs;
4908         const bool tied = SvRMAGICAL(osv)
4909                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4910         const bool can_preserve = SvCANEXISTDELETE(osv)
4911                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4912         const U32 type = SvTYPE(osv);
4913         SV *sv = NULL;
4914         if (type == SVt_PVHV) {
4915             HV * const hv = MUTABLE_HV(osv);
4916             bool preeminent = TRUE;
4917             if (can_preserve)
4918                 preeminent = hv_exists_ent(hv, keysv, 0);
4919             if (tied) {
4920                 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4921                 if (he)
4922                     sv = HeVAL(he);
4923                 else
4924                     preeminent = FALSE;
4925             }
4926             else {
4927                 sv = hv_delete_ent(hv, keysv, 0, 0);
4928                 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4929             }
4930             if (preeminent) {
4931                 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4932                 if (tied) {
4933                     SV *nsv = sv_mortalcopy(sv);
4934                     mg_clear(sv);
4935                     sv = nsv;
4936                 }
4937             }
4938             else
4939                 SAVEHDELETE(hv, keysv);
4940         }
4941         else if (type == SVt_PVAV) {
4942             if (PL_op->op_flags & OPf_SPECIAL) {
4943                 AV * const av = MUTABLE_AV(osv);
4944                 I32 idx = SvIV(keysv);
4945                 bool preeminent = TRUE;
4946                 if (can_preserve)
4947                     preeminent = av_exists(av, idx);
4948                 if (tied) {
4949                     SV **svp = av_fetch(av, idx, 1);
4950                     if (svp)
4951                         sv = *svp;
4952                     else
4953                         preeminent = FALSE;
4954                 }
4955                 else {
4956                     sv = av_delete(av, idx, 0);
4957                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4958                 }
4959                 if (preeminent) {
4960                     save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4961                     if (tied) {
4962                         SV *nsv = sv_mortalcopy(sv);
4963                         mg_clear(sv);
4964                         sv = nsv;
4965                     }
4966                 }
4967                 else
4968                     SAVEADELETE(av, idx);
4969             }
4970             else
4971                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4972         }
4973         else
4974             DIE(aTHX_ "Not a HASH reference");
4975         if (!sv)
4976             sv = &PL_sv_undef;
4977         if (gimme != G_VOID)
4978             PUSHs(sv);
4979     }
4980
4981     RETURN;
4982 }
4983
4984 PP(pp_delete)
4985 {
4986     dVAR;
4987     dSP;
4988     I32 gimme;
4989     I32 discard;
4990
4991     if (PL_op->op_private & OPpLVAL_INTRO)
4992         return do_delete_local();
4993
4994     gimme = GIMME_V;
4995     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4996
4997     if (PL_op->op_private & OPpSLICE) {
4998         dMARK; dORIGMARK;
4999         HV * const hv = MUTABLE_HV(POPs);
5000         const U32 hvtype = SvTYPE(hv);
5001         if (hvtype == SVt_PVHV) {                       /* hash element */
5002             while (++MARK <= SP) {
5003                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5004                 *MARK = sv ? sv : &PL_sv_undef;
5005             }
5006         }
5007         else if (hvtype == SVt_PVAV) {                  /* array element */
5008             if (PL_op->op_flags & OPf_SPECIAL) {
5009                 while (++MARK <= SP) {
5010                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5011                     *MARK = sv ? sv : &PL_sv_undef;
5012                 }
5013             }
5014         }
5015         else
5016             DIE(aTHX_ "Not a HASH reference");
5017         if (discard)
5018             SP = ORIGMARK;
5019         else if (gimme == G_SCALAR) {
5020             MARK = ORIGMARK;
5021             if (SP > MARK)
5022                 *++MARK = *SP;
5023             else
5024                 *++MARK = &PL_sv_undef;
5025             SP = MARK;
5026         }
5027     }
5028     else {
5029         SV *keysv = POPs;
5030         HV * const hv = MUTABLE_HV(POPs);
5031         SV *sv = NULL;
5032         if (SvTYPE(hv) == SVt_PVHV)
5033             sv = hv_delete_ent(hv, keysv, discard, 0);
5034         else if (SvTYPE(hv) == SVt_PVAV) {
5035             if (PL_op->op_flags & OPf_SPECIAL)
5036                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5037             else
5038                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5039         }
5040         else
5041             DIE(aTHX_ "Not a HASH reference");
5042         if (!sv)
5043             sv = &PL_sv_undef;
5044         if (!discard)
5045             PUSHs(sv);
5046     }
5047     RETURN;
5048 }
5049
5050 PP(pp_exists)
5051 {
5052     dVAR;
5053     dSP;
5054     SV *tmpsv;
5055     HV *hv;
5056
5057     if (PL_op->op_private & OPpEXISTS_SUB) {
5058         GV *gv;
5059         SV * const sv = POPs;
5060         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5061         if (cv)
5062             RETPUSHYES;
5063         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5064             RETPUSHYES;
5065         RETPUSHNO;
5066     }
5067     tmpsv = POPs;
5068     hv = MUTABLE_HV(POPs);
5069     if (SvTYPE(hv) == SVt_PVHV) {
5070         if (hv_exists_ent(hv, tmpsv, 0))
5071             RETPUSHYES;
5072     }
5073     else if (SvTYPE(hv) == SVt_PVAV) {
5074         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5075             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5076                 RETPUSHYES;
5077         }
5078     }
5079     else {
5080         DIE(aTHX_ "Not a HASH reference");
5081     }
5082     RETPUSHNO;
5083 }
5084
5085 PP(pp_hslice)
5086 {
5087     dVAR; dSP; dMARK; dORIGMARK;
5088     register HV * const hv = MUTABLE_HV(POPs);
5089     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5090     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5091     bool can_preserve = FALSE;
5092
5093     if (localizing) {
5094         MAGIC *mg;
5095         HV *stash;
5096
5097         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
5098             can_preserve = TRUE;
5099     }
5100
5101     while (++MARK <= SP) {
5102         SV * const keysv = *MARK;
5103         SV **svp;
5104         HE *he;
5105         bool preeminent = TRUE;
5106
5107         if (localizing && can_preserve) {
5108             /* If we can determine whether the element exist,
5109              * try to preserve the existenceness of a tied hash
5110              * element by using EXISTS and DELETE if possible.
5111              * Fallback to FETCH and STORE otherwise. */
5112             preeminent = hv_exists_ent(hv, keysv, 0);
5113         }
5114
5115         he = hv_fetch_ent(hv, keysv, lval, 0);
5116         svp = he ? &HeVAL(he) : NULL;
5117
5118         if (lval) {
5119             if (!svp || *svp == &PL_sv_undef) {
5120                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5121             }
5122             if (localizing) {
5123                 if (HvNAME_get(hv) && isGV(*svp))
5124                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5125                 else if (preeminent)
5126                     save_helem_flags(hv, keysv, svp,
5127                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5128                 else
5129                     SAVEHDELETE(hv, keysv);
5130             }
5131         }
5132         *MARK = svp ? *svp : &PL_sv_undef;
5133     }
5134     if (GIMME != G_ARRAY) {
5135         MARK = ORIGMARK;
5136         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5137         SP = MARK;
5138     }
5139     RETURN;
5140 }
5141
5142 /* List operators. */
5143
5144 PP(pp_list)
5145 {
5146     dVAR; dSP; dMARK;
5147     if (GIMME != G_ARRAY) {
5148         if (++MARK <= SP)
5149             *MARK = *SP;                /* unwanted list, return last item */
5150         else
5151             *MARK = &PL_sv_undef;
5152         SP = MARK;
5153     }
5154     RETURN;
5155 }
5156
5157 PP(pp_lslice)
5158 {
5159     dVAR;
5160     dSP;
5161     SV ** const lastrelem = PL_stack_sp;
5162     SV ** const lastlelem = PL_stack_base + POPMARK;
5163     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5164     register SV ** const firstrelem = lastlelem + 1;
5165     const I32 arybase = CopARYBASE_get(PL_curcop);
5166     I32 is_something_there = FALSE;
5167
5168     register const I32 max = lastrelem - lastlelem;
5169     register SV **lelem;
5170
5171     if (GIMME != G_ARRAY) {
5172         I32 ix = SvIV(*lastlelem);
5173         if (ix < 0)
5174             ix += max;
5175         else
5176             ix -= arybase;
5177         if (ix < 0 || ix >= max)
5178             *firstlelem = &PL_sv_undef;
5179         else
5180             *firstlelem = firstrelem[ix];
5181         SP = firstlelem;
5182         RETURN;
5183     }
5184
5185     if (max == 0) {
5186         SP = firstlelem - 1;
5187         RETURN;
5188     }
5189
5190     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5191         I32 ix = SvIV(*lelem);
5192         if (ix < 0)
5193             ix += max;
5194         else
5195             ix -= arybase;
5196         if (ix < 0 || ix >= max)
5197             *lelem = &PL_sv_undef;
5198         else {
5199             is_something_there = TRUE;
5200             if (!(*lelem = firstrelem[ix]))
5201                 *lelem = &PL_sv_undef;
5202         }
5203     }
5204     if (is_something_there)
5205         SP = lastlelem;
5206     else
5207         SP = firstlelem - 1;
5208     RETURN;
5209 }
5210
5211 PP(pp_anonlist)
5212 {
5213     dVAR; dSP; dMARK; dORIGMARK;
5214     const I32 items = SP - MARK;
5215     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5216     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
5217     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5218             ? newRV_noinc(av) : av);
5219     RETURN;
5220 }
5221
5222 PP(pp_anonhash)
5223 {
5224     dVAR; dSP; dMARK; dORIGMARK;
5225     HV* const hv = newHV();
5226
5227     while (MARK < SP) {
5228         SV * const key = *++MARK;
5229         SV * const val = newSV(0);
5230         if (MARK < SP)
5231             sv_setsv(val, *++MARK);
5232         else
5233             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5234         (void)hv_store_ent(hv,key,val,0);
5235     }
5236     SP = ORIGMARK;
5237     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5238             ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5239     RETURN;
5240 }
5241
5242 PP(pp_splice)
5243 {
5244     dVAR; dSP; dMARK; dORIGMARK;
5245     register AV *ary = MUTABLE_AV(*++MARK);
5246     register SV **src;
5247     register SV **dst;
5248     register I32 i;
5249     register I32 offset;
5250     register I32 length;
5251     I32 newlen;
5252     I32 after;
5253     I32 diff;
5254     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5255
5256     if (mg) {
5257         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5258         PUSHMARK(MARK);
5259         PUTBACK;
5260         ENTER_with_name("call_SPLICE");
5261         call_method("SPLICE",GIMME_V);
5262         LEAVE_with_name("call_SPLICE");
5263         SPAGAIN;
5264         RETURN;
5265     }
5266
5267     SP++;
5268
5269     if (++MARK < SP) {
5270         offset = i = SvIV(*MARK);
5271         if (offset < 0)
5272             offset += AvFILLp(ary) + 1;
5273         else
5274             offset -= CopARYBASE_get(PL_curcop);
5275         if (offset < 0)
5276             DIE(aTHX_ PL_no_aelem, i);
5277         if (++MARK < SP) {
5278             length = SvIVx(*MARK++);
5279             if (length < 0) {
5280                 length += AvFILLp(ary) - offset + 1;
5281                 if (length < 0)
5282                     length = 0;
5283             }
5284         }
5285         else
5286             length = AvMAX(ary) + 1;            /* close enough to infinity */
5287     }
5288     else {
5289         offset = 0;
5290         length = AvMAX(ary) + 1;
5291     }
5292     if (offset > AvFILLp(ary) + 1) {
5293         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5294         offset = AvFILLp(ary) + 1;
5295     }
5296     after = AvFILLp(ary) + 1 - (offset + length);
5297     if (after < 0) {                            /* not that much array */
5298         length += after;                        /* offset+length now in array */
5299         after = 0;
5300         if (!AvALLOC(ary))
5301             av_extend(ary, 0);
5302     }
5303
5304     /* At this point, MARK .. SP-1 is our new LIST */
5305
5306     newlen = SP - MARK;
5307     diff = newlen - length;
5308     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5309         av_reify(ary);
5310
5311     /* make new elements SVs now: avoid problems if they're from the array */
5312     for (dst = MARK, i = newlen; i; i--) {
5313         SV * const h = *dst;
5314         *dst++ = newSVsv(h);
5315     }
5316
5317     if (diff < 0) {                             /* shrinking the area */
5318         SV **tmparyval = NULL;
5319         if (newlen) {
5320             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5321             Copy(MARK, tmparyval, newlen, SV*);
5322         }
5323
5324         MARK = ORIGMARK + 1;
5325         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5326             MEXTEND(MARK, length);
5327             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5328             if (AvREAL(ary)) {
5329                 EXTEND_MORTAL(length);
5330                 for (i = length, dst = MARK; i; i--) {
5331                     sv_2mortal(*dst);   /* free them eventualy */
5332                     dst++;
5333                 }
5334             }
5335             MARK += length - 1;
5336         }
5337         else {
5338             *MARK = AvARRAY(ary)[offset+length-1];
5339             if (AvREAL(ary)) {
5340                 sv_2mortal(*MARK);
5341                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5342                     SvREFCNT_dec(*dst++);       /* free them now */
5343             }
5344         }
5345         AvFILLp(ary) += diff;
5346
5347         /* pull up or down? */
5348
5349         if (offset < after) {                   /* easier to pull up */
5350             if (offset) {                       /* esp. if nothing to pull */
5351                 src = &AvARRAY(ary)[offset-1];
5352                 dst = src - diff;               /* diff is negative */
5353                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5354                     *dst-- = *src--;
5355             }
5356             dst = AvARRAY(ary);
5357             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5358             AvMAX(ary) += diff;
5359         }
5360         else {
5361             if (after) {                        /* anything to pull down? */
5362                 src = AvARRAY(ary) + offset + length;
5363                 dst = src + diff;               /* diff is negative */
5364                 Move(src, dst, after, SV*);
5365             }
5366             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5367                                                 /* avoid later double free */
5368         }
5369         i = -diff;
5370         while (i)
5371             dst[--i] = &PL_sv_undef;
5372
5373         if (newlen) {
5374             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5375             Safefree(tmparyval);
5376         }
5377     }
5378     else {                                      /* no, expanding (or same) */
5379         SV** tmparyval = NULL;
5380         if (length) {
5381             Newx(tmparyval, length, SV*);       /* so remember deletion */
5382             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5383         }
5384
5385         if (diff > 0) {                         /* expanding */
5386             /* push up or down? */
5387             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5388                 if (offset) {
5389                     src = AvARRAY(ary);
5390                     dst = src - diff;
5391                     Move(src, dst, offset, SV*);
5392                 }
5393                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5394                 AvMAX(ary) += diff;
5395                 AvFILLp(ary) += diff;
5396             }
5397             else {
5398                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5399                     av_extend(ary, AvFILLp(ary) + diff);
5400                 AvFILLp(ary) += diff;
5401
5402                 if (after) {
5403                     dst = AvARRAY(ary) + AvFILLp(ary);
5404                     src = dst - diff;
5405                     for (i = after; i; i--) {
5406                         *dst-- = *src--;
5407                     }
5408                 }
5409             }
5410         }
5411
5412         if (newlen) {
5413             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5414         }
5415
5416         MARK = ORIGMARK + 1;
5417         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5418             if (length) {
5419                 Copy(tmparyval, MARK, length, SV*);
5420                 if (AvREAL(ary)) {
5421                     EXTEND_MORTAL(length);
5422                     for (i = length, dst = MARK; i; i--) {
5423                         sv_2mortal(*dst);       /* free them eventualy */
5424                         dst++;
5425                     }
5426                 }
5427             }
5428             MARK += length - 1;
5429         }
5430         else if (length--) {
5431             *MARK = tmparyval[length];
5432             if (AvREAL(ary)) {
5433                 sv_2mortal(*MARK);
5434                 while (length-- > 0)
5435                     SvREFCNT_dec(tmparyval[length]);
5436             }
5437         }
5438         else
5439             *MARK = &PL_sv_undef;
5440         Safefree(tmparyval);
5441     }
5442
5443     if (SvMAGICAL(ary))
5444         mg_set(MUTABLE_SV(ary));
5445
5446     SP = MARK;
5447     RETURN;
5448 }
5449
5450 PP(pp_push)
5451 {
5452     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5453     register AV * const ary = MUTABLE_AV(*++MARK);
5454     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5455
5456     if (mg) {
5457         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5458         PUSHMARK(MARK);
5459         PUTBACK;
5460         ENTER_with_name("call_PUSH");
5461         call_method("PUSH",G_SCALAR|G_DISCARD);
5462         LEAVE_with_name("call_PUSH");
5463         SPAGAIN;
5464     }
5465     else {
5466         PL_delaymagic = DM_DELAY;
5467         for (++MARK; MARK <= SP; MARK++) {
5468             SV * const sv = newSV(0);
5469             if (*MARK)
5470                 sv_setsv(sv, *MARK);
5471             av_store(ary, AvFILLp(ary)+1, sv);
5472         }
5473         if (PL_delaymagic & DM_ARRAY_ISA)
5474             mg_set(MUTABLE_SV(ary));
5475
5476         PL_delaymagic = 0;
5477     }
5478     SP = ORIGMARK;
5479     if (OP_GIMME(PL_op, 0) != G_VOID) {
5480         PUSHi( AvFILL(ary) + 1 );
5481     }
5482     RETURN;
5483 }
5484
5485 PP(pp_shift)
5486 {
5487     dVAR;
5488     dSP;
5489     AV * const av = PL_op->op_flags & OPf_SPECIAL
5490         ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5491     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5492     EXTEND(SP, 1);
5493     assert (sv);
5494     if (AvREAL(av))
5495         (void)sv_2mortal(sv);
5496     PUSHs(sv);
5497     RETURN;
5498 }
5499
5500 PP(pp_unshift)
5501 {
5502     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5503     register AV *ary = MUTABLE_AV(*++MARK);
5504     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5505
5506     if (mg) {
5507         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5508         PUSHMARK(MARK);
5509         PUTBACK;
5510         ENTER_with_name("call_UNSHIFT");
5511         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5512         LEAVE_with_name("call_UNSHIFT");
5513         SPAGAIN;
5514     }
5515     else {
5516         register I32 i = 0;
5517         av_unshift(ary, SP - MARK);
5518         while (MARK < SP) {
5519             SV * const sv = newSVsv(*++MARK);
5520             (void)av_store(ary, i++, sv);
5521         }
5522     }
5523     SP = ORIGMARK;
5524     if (OP_GIMME(PL_op, 0) != G_VOID) {
5525         PUSHi( AvFILL(ary) + 1 );
5526     }
5527     RETURN;
5528 }
5529
5530 PP(pp_reverse)
5531 {
5532     dVAR; dSP; dMARK;
5533
5534     if (GIMME == G_ARRAY) {
5535         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5536             AV *av;
5537
5538             /* See pp_sort() */
5539             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5540             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5541             av = MUTABLE_AV((*SP));
5542             /* In-place reversing only happens in void context for the array
5543              * assignment. We don't need to push anything on the stack. */
5544             SP = MARK;
5545
5546             if (SvMAGICAL(av)) {
5547                 I32 i, j;
5548                 register SV *tmp = sv_newmortal();
5549                 /* For SvCANEXISTDELETE */
5550                 HV *stash;
5551                 const MAGIC *mg;
5552                 bool can_preserve = SvCANEXISTDELETE(av);
5553
5554                 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5555                     register SV *begin, *end;
5556
5557                     if (can_preserve) {
5558                         if (!av_exists(av, i)) {
5559                             if (av_exists(av, j)) {
5560                                 register SV *sv = av_delete(av, j, 0);
5561                                 begin = *av_fetch(av, i, TRUE);
5562                                 sv_setsv_mg(begin, sv);
5563                             }
5564                             continue;
5565                         }
5566                         else if (!av_exists(av, j)) {
5567                             register SV *sv = av_delete(av, i, 0);
5568                             end = *av_fetch(av, j, TRUE);
5569                             sv_setsv_mg(end, sv);
5570                             continue;
5571                         }
5572                     }
5573
5574                     begin = *av_fetch(av, i, TRUE);
5575                     end   = *av_fetch(av, j, TRUE);
5576                     sv_setsv(tmp,      begin);
5577                     sv_setsv_mg(begin, end);
5578                     sv_setsv_mg(end,   tmp);
5579                 }
5580             }
5581             else {
5582                 SV **begin = AvARRAY(av);
5583
5584                 if (begin) {
5585                     SV **end   = begin + AvFILLp(av);
5586
5587                     while (begin < end) {
5588                         register SV * const tmp = *begin;
5589                         *begin++ = *end;
5590                         *end--   = tmp;
5591                     }
5592                 }
5593             }
5594         }
5595         else {
5596             SV **oldsp = SP;
5597             MARK++;
5598             while (MARK < SP) {
5599                 register SV * const tmp = *MARK;
5600                 *MARK++ = *SP;
5601                 *SP--   = tmp;
5602             }
5603             /* safe as long as stack cannot get extended in the above */
5604             SP = oldsp;
5605         }
5606     }
5607     else {
5608         register char *up;
5609         register char *down;
5610         register I32 tmp;
5611         dTARGET;
5612         STRLEN len;
5613
5614         SvUTF8_off(TARG);                               /* decontaminate */
5615         if (SP - MARK > 1)
5616             do_join(TARG, &PL_sv_no, MARK, SP);
5617         else {
5618             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5619             if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5620                 report_uninit(TARG);
5621         }
5622
5623         up = SvPV_force(TARG, len);
5624         if (len > 1) {
5625             if (DO_UTF8(TARG)) {        /* first reverse each character */
5626                 U8* s = (U8*)SvPVX(TARG);
5627                 const U8* send = (U8*)(s + len);
5628                 while (s < send) {
5629                     if (UTF8_IS_INVARIANT(*s)) {
5630                         s++;
5631                         continue;
5632                     }
5633                     else {
5634                         if (!utf8_to_uvchr(s, 0))
5635                             break;
5636                         up = (char*)s;
5637                         s += UTF8SKIP(s);
5638                         down = (char*)(s - 1);
5639                         /* reverse this character */
5640                         while (down > up) {
5641                             tmp = *up;
5642                             *up++ = *down;
5643                             *down-- = (char)tmp;
5644                         }
5645                     }
5646                 }
5647                 up = SvPVX(TARG);
5648             }
5649             down = SvPVX(TARG) + len - 1;
5650             while (down > up) {
5651                 tmp = *up;
5652                 *up++ = *down;
5653                 *down-- = (char)tmp;
5654             }
5655             (void)SvPOK_only_UTF8(TARG);
5656         }
5657         SP = MARK + 1;
5658         SETTARG;
5659     }
5660     RETURN;
5661 }
5662
5663 PP(pp_split)
5664 {
5665     dVAR; dSP; dTARG;
5666     AV *ary;
5667     register IV limit = POPi;                   /* note, negative is forever */
5668     SV * const sv = POPs;
5669     STRLEN len;
5670     register const char *s = SvPV_const(sv, len);
5671     const bool do_utf8 = DO_UTF8(sv);
5672     const char *strend = s + len;
5673     register PMOP *pm;
5674     register REGEXP *rx;
5675     register SV *dstr;
5676     register const char *m;
5677     I32 iters = 0;
5678     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5679     I32 maxiters = slen + 10;
5680     I32 trailing_empty = 0;
5681     const char *orig;
5682     const I32 origlimit = limit;
5683     I32 realarray = 0;
5684     I32 base;
5685     const I32 gimme = GIMME_V;
5686     bool gimme_scalar;
5687     const I32 oldsave = PL_savestack_ix;
5688     U32 make_mortal = SVs_TEMP;
5689     bool multiline = 0;
5690     MAGIC *mg = NULL;
5691
5692 #ifdef DEBUGGING
5693     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5694 #else
5695     pm = (PMOP*)POPs;
5696 #endif
5697     if (!pm || !s)
5698         DIE(aTHX_ "panic: pp_split");
5699     rx = PM_GETRE(pm);
5700
5701     TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5702              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5703
5704     RX_MATCH_UTF8_set(rx, do_utf8);
5705
5706 #ifdef USE_ITHREADS
5707     if (pm->op_pmreplrootu.op_pmtargetoff) {
5708         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5709     }
5710 #else
5711     if (pm->op_pmreplrootu.op_pmtargetgv) {
5712         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5713     }
5714 #endif
5715     else
5716         ary = NULL;
5717     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5718         realarray = 1;
5719         PUTBACK;
5720         av_extend(ary,0);
5721         av_clear(ary);
5722         SPAGAIN;
5723         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5724             PUSHMARK(SP);
5725             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5726         }
5727         else {
5728             if (!AvREAL(ary)) {
5729                 I32 i;
5730                 AvREAL_on(ary);
5731                 AvREIFY_off(ary);
5732                 for (i = AvFILLp(ary); i >= 0; i--)
5733                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5734             }
5735             /* temporarily switch stacks */
5736             SAVESWITCHSTACK(PL_curstack, ary);
5737             make_mortal = 0;
5738         }
5739     }
5740     base = SP - PL_stack_base;
5741     orig = s;
5742     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5743         if (do_utf8) {
5744             while (*s == ' ' || is_utf8_space((U8*)s))
5745                 s += UTF8SKIP(s);
5746         }
5747         else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5748             while (isSPACE_LC(*s))
5749                 s++;
5750         }
5751         else {
5752             while (isSPACE(*s))
5753                 s++;
5754         }
5755     }
5756     if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5757         multiline = 1;
5758     }
5759
5760     gimme_scalar = gimme == G_SCALAR && !ary;
5761
5762     if (!limit)
5763         limit = maxiters + 2;
5764     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5765         while (--limit) {
5766             m = s;
5767             /* this one uses 'm' and is a negative test */
5768             if (do_utf8) {
5769                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5770                     const int t = UTF8SKIP(m);
5771                     /* is_utf8_space returns FALSE for malform utf8 */
5772                     if (strend - m < t)
5773                         m = strend;
5774                     else
5775                         m += t;
5776                 }
5777             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5778                 while (m < strend && !isSPACE_LC(*m))
5779                     ++m;
5780             } else {
5781                 while (m < strend && !isSPACE(*m))
5782                     ++m;
5783             }
5784             if (m >= strend)
5785                 break;
5786
5787             if (gimme_scalar) {
5788                 iters++;
5789                 if (m-s == 0)
5790                     trailing_empty++;
5791                 else
5792                     trailing_empty = 0;
5793             } else {
5794                 dstr = newSVpvn_flags(s, m-s,
5795                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5796                 XPUSHs(dstr);
5797             }
5798
5799             /* skip the whitespace found last */
5800             if (do_utf8)
5801                 s = m + UTF8SKIP(m);
5802             else
5803                 s = m + 1;
5804
5805             /* this one uses 's' and is a positive test */
5806             if (do_utf8) {
5807                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5808                     s +=  UTF8SKIP(s);
5809             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5810                 while (s < strend && isSPACE_LC(*s))
5811                     ++s;
5812             } else {
5813                 while (s < strend && isSPACE(*s))
5814                     ++s;
5815             }
5816         }
5817     }
5818     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5819         while (--limit) {
5820             for (m = s; m < strend && *m != '\n'; m++)
5821                 ;
5822             m++;
5823             if (m >= strend)
5824                 break;
5825
5826             if (gimme_scalar) {
5827                 iters++;
5828                 if (m-s == 0)
5829                     trailing_empty++;
5830                 else
5831                     trailing_empty = 0;
5832             } else {
5833                 dstr = newSVpvn_flags(s, m-s,
5834                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5835                 XPUSHs(dstr);
5836             }
5837             s = m;
5838         }
5839     }
5840     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5841         /*
5842           Pre-extend the stack, either the number of bytes or
5843           characters in the string or a limited amount, triggered by:
5844
5845           my ($x, $y) = split //, $str;
5846             or
5847           split //, $str, $i;
5848         */
5849         if (!gimme_scalar) {
5850             const U32 items = limit - 1;
5851             if (items < slen)
5852                 EXTEND(SP, items);
5853             else
5854                 EXTEND(SP, slen);
5855         }
5856
5857         if (do_utf8) {
5858             while (--limit) {
5859                 /* keep track of how many bytes we skip over */
5860                 m = s;
5861                 s += UTF8SKIP(s);
5862                 if (gimme_scalar) {
5863                     iters++;
5864                     if (s-m == 0)
5865                         trailing_empty++;
5866                     else
5867                         trailing_empty = 0;
5868                 } else {
5869                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5870
5871                     PUSHs(dstr);
5872                 }
5873
5874                 if (s >= strend)
5875                     break;
5876             }
5877         } else {
5878             while (--limit) {
5879                 if (gimme_scalar) {
5880                     iters++;
5881                 } else {
5882                     dstr = newSVpvn(s, 1);
5883
5884
5885                     if (make_mortal)
5886                         sv_2mortal(dstr);
5887
5888                     PUSHs(dstr);
5889                 }
5890
5891                 s++;
5892
5893                 if (s >= strend)
5894                     break;
5895             }
5896         }
5897     }
5898     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5899              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5900              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5901              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5902         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5903         SV * const csv = CALLREG_INTUIT_STRING(rx);
5904
5905         len = RX_MINLENRET(rx);
5906         if (len == 1 && !RX_UTF8(rx) && !tail) {
5907             const char c = *SvPV_nolen_const(csv);
5908             while (--limit) {
5909                 for (m = s; m < strend && *m != c; m++)
5910                     ;
5911                 if (m >= strend)
5912                     break;
5913                 if (gimme_scalar) {
5914                     iters++;
5915                     if (m-s == 0)
5916                         trailing_empty++;
5917                     else
5918                         trailing_empty = 0;
5919                 } else {
5920                     dstr = newSVpvn_flags(s, m-s,
5921                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5922                     XPUSHs(dstr);
5923                 }
5924                 /* The rx->minlen is in characters but we want to step
5925                  * s ahead by bytes. */
5926                 if (do_utf8)
5927                     s = (char*)utf8_hop((U8*)m, len);
5928                 else
5929                     s = m + len; /* Fake \n at the end */
5930             }
5931         }
5932         else {
5933             while (s < strend && --limit &&
5934               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5935                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5936             {
5937                 if (gimme_scalar) {
5938                     iters++;
5939                     if (m-s == 0)
5940                         trailing_empty++;
5941                     else
5942                         trailing_empty = 0;
5943                 } else {
5944                     dstr = newSVpvn_flags(s, m-s,
5945                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5946                     XPUSHs(dstr);
5947                 }
5948                 /* The rx->minlen is in characters but we want to step
5949                  * s ahead by bytes. */
5950                 if (do_utf8)
5951                     s = (char*)utf8_hop((U8*)m, len);
5952                 else
5953                     s = m + len; /* Fake \n at the end */
5954             }
5955         }
5956     }
5957     else {
5958         maxiters += slen * RX_NPARENS(rx);
5959         while (s < strend && --limit)
5960         {
5961             I32 rex_return;
5962             PUTBACK;
5963             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5964                             sv, NULL, 0);
5965             SPAGAIN;
5966             if (rex_return == 0)
5967                 break;
5968             TAINT_IF(RX_MATCH_TAINTED(rx));
5969             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5970                 m = s;
5971                 s = orig;
5972                 orig = RX_SUBBEG(rx);
5973                 s = orig + (m - s);
5974                 strend = s + (strend - m);
5975             }
5976             m = RX_OFFS(rx)[0].start + orig;
5977
5978             if (gimme_scalar) {
5979                 iters++;
5980                 if (m-s == 0)
5981                     trailing_empty++;
5982                 else
5983                     trailing_empty = 0;
5984             } else {
5985                 dstr = newSVpvn_flags(s, m-s,
5986                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5987                 XPUSHs(dstr);
5988             }
5989             if (RX_NPARENS(rx)) {
5990                 I32 i;
5991                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5992                     s = RX_OFFS(rx)[i].start + orig;
5993                     m = RX_OFFS(rx)[i].end + orig;
5994
5995                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5996                        parens that didn't match -- they should be set to
5997                        undef, not the empty string */
5998                     if (gimme_scalar) {
5999                         iters++;
6000                         if (m-s == 0)
6001                             trailing_empty++;
6002                         else
6003                             trailing_empty = 0;
6004                     } else {
6005                         if (m >= orig && s >= orig) {
6006                             dstr = newSVpvn_flags(s, m-s,
6007                                                  (do_utf8 ? SVf_UTF8 : 0)
6008                                                   | make_mortal);
6009                         }
6010                         else
6011                             dstr = &PL_sv_undef;  /* undef, not "" */
6012                         XPUSHs(dstr);
6013                     }
6014
6015                 }
6016             }
6017             s = RX_OFFS(rx)[0].end + orig;
6018         }
6019     }
6020
6021     if (!gimme_scalar) {
6022         iters = (SP - PL_stack_base) - base;
6023     }
6024     if (iters > maxiters)
6025         DIE(aTHX_ "Split loop");
6026
6027     /* keep field after final delim? */
6028     if (s < strend || (iters && origlimit)) {
6029         if (!gimme_scalar) {
6030             const STRLEN l = strend - s;
6031             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6032             XPUSHs(dstr);
6033         }
6034         iters++;
6035     }
6036     else if (!origlimit) {
6037         if (gimme_scalar) {
6038             iters -= trailing_empty;
6039         } else {
6040             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6041                 if (TOPs && !make_mortal)
6042                     sv_2mortal(TOPs);
6043                 *SP-- = &PL_sv_undef;
6044                 iters--;
6045             }
6046         }
6047     }
6048
6049     PUTBACK;
6050     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6051     SPAGAIN;
6052     if (realarray) {
6053         if (!mg) {
6054             if (SvSMAGICAL(ary)) {
6055                 PUTBACK;
6056                 mg_set(MUTABLE_SV(ary));
6057                 SPAGAIN;
6058             }
6059             if (gimme == G_ARRAY) {
6060                 EXTEND(SP, iters);
6061                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6062                 SP += iters;
6063                 RETURN;
6064             }
6065         }
6066         else {
6067             PUTBACK;
6068             ENTER_with_name("call_PUSH");
6069             call_method("PUSH",G_SCALAR|G_DISCARD);
6070             LEAVE_with_name("call_PUSH");
6071             SPAGAIN;
6072             if (gimme == G_ARRAY) {
6073                 I32 i;
6074                 /* EXTEND should not be needed - we just popped them */
6075                 EXTEND(SP, iters);
6076                 for (i=0; i < iters; i++) {
6077                     SV **svp = av_fetch(ary, i, FALSE);
6078                     PUSHs((svp) ? *svp : &PL_sv_undef);
6079                 }
6080                 RETURN;
6081             }
6082         }
6083     }
6084     else {
6085         if (gimme == G_ARRAY)
6086             RETURN;
6087     }
6088
6089     GETTARGET;
6090     PUSHi(iters);
6091     RETURN;
6092 }
6093
6094 PP(pp_once)
6095 {
6096     dSP;
6097     SV *const sv = PAD_SVl(PL_op->op_targ);
6098
6099     if (SvPADSTALE(sv)) {
6100         /* First time. */
6101         SvPADSTALE_off(sv);
6102         RETURNOP(cLOGOP->op_other);
6103     }
6104     RETURNOP(cLOGOP->op_next);
6105 }
6106
6107 PP(pp_lock)
6108 {
6109     dVAR;
6110     dSP;
6111     dTOPss;
6112     SV *retsv = sv;
6113     assert(SvTYPE(retsv) != SVt_PVCV);
6114     SvLOCK(sv);
6115     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6116         retsv = refto(retsv);
6117     }
6118     SETs(retsv);
6119     RETURN;
6120 }
6121
6122
6123 PP(unimplemented_op)
6124 {
6125     dVAR;
6126     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
6127         PL_op->op_type);
6128 }
6129
6130 PP(pp_boolkeys)
6131 {
6132     dVAR;
6133     dSP;
6134     HV * const hv = (HV*)POPs;
6135
6136     if (SvRMAGICAL(hv)) {
6137         MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6138         if (mg) {
6139             XPUSHs(magic_scalarpack(hv, mg));
6140             RETURN;
6141         }
6142     }
6143
6144     XPUSHs(boolSV(HvKEYS(hv) != 0));
6145     RETURN;
6146 }
6147
6148 /*
6149  * Local variables:
6150  * c-indentation-style: bsd
6151  * c-basic-offset: 4
6152  * indent-tabs-mode: t
6153  * End:
6154  *
6155  * ex: set ts=8 sts=4 sw=4 noet:
6156  */