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