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