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