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