pp.c

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