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 #include "regcharclass.h"
  33
  34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  35    it, since pid_t is an integral type.
  36    --AD  2/20/1998
  37 */
  38 #ifdef NEED_GETPID_PROTO
  39 extern Pid_t getpid (void);
  40 #endif
  41
  42 /*
  43  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
  44  * This switches them over to IEEE.
  45  */
  46 #if defined(LIBM_LIB_VERSION)
  47     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
  48 #endif
  49
  50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
  51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
  52
  53 /* variations on pp_null */
  54
  55 PP(pp_stub)
  56 {
  57     dSP;
  58     if (GIMME_V == G_SCALAR)
  59         XPUSHs(&PL_sv_undef);
  60     RETURN;
  61 }
  62
  63 /* Pushy stuff. */
  64
  65 /* This is also called directly by pp_lvavref.  */
  66 PP(pp_padav)
  67 {
  68     dSP; dTARGET;
  69     I32 gimme;
  70     assert(SvTYPE(TARG) == SVt_PVAV);
  71     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
  72         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
  73             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  74     EXTEND(SP, 1);
  75
  76     if (PL_op->op_flags & OPf_REF) {
  77         PUSHs(TARG);
  78         RETURN;
  79     }
  80     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
  81         const I32 flags = is_lvalue_sub();
  82         if (flags && !(flags & OPpENTERSUB_INARGS)) {
  83             if (GIMME_V == G_SCALAR)
  84                 /* diag_listed_as: Can't return %s to lvalue scalar context */
  85                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  86             PUSHs(TARG);
  87             RETURN;
  88        }
  89     }
  90
  91     gimme = GIMME_V;
  92     if (gimme == G_ARRAY) {
  93         /* XXX see also S_pushav in pp_hot.c */
  94         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
  95         EXTEND(SP, maxarg);
  96         if (SvMAGICAL(TARG)) {
  97             SSize_t i;
  98             for (i=0; i < maxarg; i++) {
  99                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
 100                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 101             }
 102         }
 103         else {
 104             SSize_t i;
 105             for (i=0; i < maxarg; i++) {
 106                 SV * const sv = AvARRAY((const AV *)TARG)[i];
 107                 SP[i+1] = sv ? sv : &PL_sv_undef;
 108             }
 109         }
 110         SP += maxarg;
 111     }
 112     else if (gimme == G_SCALAR) {
 113         SV* const sv = sv_newmortal();
 114         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
 115         sv_setiv(sv, maxarg);
 116         PUSHs(sv);
 117     }
 118     RETURN;
 119 }
 120
 121 PP(pp_padhv)
 122 {
 123     dSP; dTARGET;
 124     I32 gimme;
 125
 126     assert(SvTYPE(TARG) == SVt_PVHV);
 127     XPUSHs(TARG);
 128     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
 129         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
 130             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 131
 132     if (PL_op->op_flags & OPf_REF)
 133         RETURN;
 134     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
 135         const I32 flags = is_lvalue_sub();
 136         if (flags && !(flags & OPpENTERSUB_INARGS)) {
 137             if (GIMME_V == G_SCALAR)
 138                 /* diag_listed_as: Can't return %s to lvalue scalar context */
 139                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 140             RETURN;
 141         }
 142     }
 143
 144     gimme = GIMME_V;
 145     if (gimme == G_ARRAY) {
 146         RETURNOP(Perl_do_kv(aTHX));
 147     }
 148     else if ((PL_op->op_private & OPpTRUEBOOL
 149           || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
 150              && block_gimme() == G_VOID  ))
 151           && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
 152     )
 153         SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
 154     else if (gimme == G_SCALAR) {
 155         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
 156         SETs(sv);
 157     }
 158     RETURN;
 159 }
 160
 161 PP(pp_padcv)
 162 {
 163     dSP; dTARGET;
 164     assert(SvTYPE(TARG) == SVt_PVCV);
 165     XPUSHs(TARG);
 166     RETURN;
 167 }
 168
 169 PP(pp_introcv)
 170 {
 171     dTARGET;
 172     SvPADSTALE_off(TARG);
 173     return NORMAL;
 174 }
 175
 176 PP(pp_clonecv)
 177 {
 178     dTARGET;
 179     CV * const protocv = PadnamePROTOCV(
 180         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
 181     );
 182     assert(SvTYPE(TARG) == SVt_PVCV);
 183     assert(protocv);
 184     if (CvISXSUB(protocv)) { /* constant */
 185         /* XXX Should we clone it here? */
 186         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
 187            to introcv and remove the SvPADSTALE_off. */
 188         SAVEPADSVANDMORTALIZE(ARGTARG);
 189         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
 190     }
 191     else {
 192         if (CvROOT(protocv)) {
 193             assert(CvCLONE(protocv));
 194             assert(!CvCLONED(protocv));
 195         }
 196         cv_clone_into(protocv,(CV *)TARG);
 197         SAVECLEARSV(PAD_SVl(ARGTARG));
 198     }
 199     return NORMAL;
 200 }
 201
 202 /* Translations. */
 203
 204 /* In some cases this function inspects PL_op.  If this function is called
 205    for new op types, more bool parameters may need to be added in place of
 206    the checks.
 207
 208    When noinit is true, the absence of a gv will cause a retval of undef.
 209    This is unrelated to the cv-to-gv assignment case.
 210 */
 211
 212 static SV *
 213 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
 214               const bool noinit)
 215 {
 216     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
 217     if (SvROK(sv)) {
 218         if (SvAMAGIC(sv)) {
 219             sv = amagic_deref_call(sv, to_gv_amg);
 220         }
 221       wasref:
 222         sv = SvRV(sv);
 223         if (SvTYPE(sv) == SVt_PVIO) {
 224             GV * const gv = MUTABLE_GV(sv_newmortal());
 225             gv_init(gv, 0, "__ANONIO__", 10, 0);
 226             GvIOp(gv) = MUTABLE_IO(sv);
 227             SvREFCNT_inc_void_NN(sv);
 228             sv = MUTABLE_SV(gv);
 229         }
 230         else if (!isGV_with_GP(sv)) {
 231             Perl_die(aTHX_ "Not a GLOB reference");
 232         }
 233     }
 234     else {
 235         if (!isGV_with_GP(sv)) {
 236             if (!SvOK(sv)) {
 237                 /* If this is a 'my' scalar and flag is set then vivify
 238                  * NI-S 1999/05/07
 239                  */
 240                 if (vivify_sv && sv != &PL_sv_undef) {
 241                     GV *gv;
 242                     if (SvREADONLY(sv))
 243                         Perl_croak_no_modify();
 244                     if (cUNOP->op_targ) {
 245                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 246                         HV *stash = CopSTASH(PL_curcop);
 247                         if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
 248                         gv = MUTABLE_GV(newSV(0));
 249                         gv_init_sv(gv, stash, namesv, 0);
 250                     }
 251                     else {
 252                         const char * const name = CopSTASHPV(PL_curcop);
 253                         gv = newGVgen_flags(name,
 254                                 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
 255                         SvREFCNT_inc_simple_void_NN(gv);
 256                     }
 257                     prepare_SV_for_RV(sv);
 258                     SvRV_set(sv, MUTABLE_SV(gv));
 259                     SvROK_on(sv);
 260                     SvSETMAGIC(sv);
 261                     goto wasref;
 262                 }
 263                 if (PL_op->op_flags & OPf_REF || strict) {
 264                     Perl_die(aTHX_ PL_no_usym, "a symbol");
 265                 }
 266                 if (ckWARN(WARN_UNINITIALIZED))
 267                     report_uninit(sv);
 268                 return &PL_sv_undef;
 269             }
 270             if (noinit)
 271             {
 272                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
 273                            sv, GV_ADDMG, SVt_PVGV
 274                    ))))
 275                     return &PL_sv_undef;
 276             }
 277             else {
 278                 if (strict) {
 279                     Perl_die(aTHX_
 280                              PL_no_symref_sv,
 281                              sv,
 282                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
 283                              "a symbol"
 284                              );
 285                 }
 286                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 287                     == OPpDONT_INIT_GV) {
 288                     /* We are the target of a coderef assignment.  Return
 289                        the scalar unchanged, and let pp_sasssign deal with
 290                        things.  */
 291                     return sv;
 292                 }
 293                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
 294             }
 295             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 296             SvFAKE_off(sv);
 297         }
 298     }
 299     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
 300         SV *newsv = sv_newmortal();
 301         sv_setsv_flags(newsv, sv, 0);
 302         SvFAKE_off(newsv);
 303         sv = newsv;
 304     }
 305     return sv;
 306 }
 307
 308 PP(pp_rv2gv)
 309 {
 310     dSP; dTOPss;
 311
 312     sv = S_rv2gv(aTHX_
 313           sv, PL_op->op_private & OPpDEREF,
 314           PL_op->op_private & HINT_STRICT_REFS,
 315           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
 316              || PL_op->op_type == OP_READLINE
 317          );
 318     if (PL_op->op_private & OPpLVAL_INTRO)
 319         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 320     SETs(sv);
 321     RETURN;
 322 }
 323
 324 /* Helper function for pp_rv2sv and pp_rv2av  */
 325 GV *
 326 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 327                 const svtype type, SV ***spp)
 328 {
 329     GV *gv;
 330
 331     PERL_ARGS_ASSERT_SOFTREF2XV;
 332
 333     if (PL_op->op_private & HINT_STRICT_REFS) {
 334         if (SvOK(sv))
 335             Perl_die(aTHX_ PL_no_symref_sv, sv,
 336                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 337         else
 338             Perl_die(aTHX_ PL_no_usym, what);
 339     }
 340     if (!SvOK(sv)) {
 341         if (
 342           PL_op->op_flags & OPf_REF
 343         )
 344             Perl_die(aTHX_ PL_no_usym, what);
 345         if (ckWARN(WARN_UNINITIALIZED))
 346             report_uninit(sv);
 347         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 348             (*spp)--;
 349             return NULL;
 350         }
 351         **spp = &PL_sv_undef;
 352         return NULL;
 353     }
 354     if ((PL_op->op_flags & OPf_SPECIAL) &&
 355         !(PL_op->op_flags & OPf_MOD))
 356         {
 357             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
 358                 {
 359                     **spp = &PL_sv_undef;
 360                     return NULL;
 361                 }
 362         }
 363     else {
 364         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
 365     }
 366     return gv;
 367 }
 368
 369 PP(pp_rv2sv)
 370 {
 371     dSP; dTOPss;
 372     GV *gv = NULL;
 373
 374     SvGETMAGIC(sv);
 375     if (SvROK(sv)) {
 376         if (SvAMAGIC(sv)) {
 377             sv = amagic_deref_call(sv, to_sv_amg);
 378         }
 379
 380         sv = SvRV(sv);
 381         if (SvTYPE(sv) >= SVt_PVAV)
 382             DIE(aTHX_ "Not a SCALAR reference");
 383     }
 384     else {
 385         gv = MUTABLE_GV(sv);
 386
 387         if (!isGV_with_GP(gv)) {
 388             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 389             if (!gv)
 390                 RETURN;
 391         }
 392         sv = GvSVn(gv);
 393     }
 394     if (PL_op->op_flags & OPf_MOD) {
 395         if (PL_op->op_private & OPpLVAL_INTRO) {
 396             if (cUNOP->op_first->op_type == OP_NULL)
 397                 sv = save_scalar(MUTABLE_GV(TOPs));
 398             else if (gv)
 399                 sv = save_scalar(gv);
 400             else
 401                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 402         }
 403         else if (PL_op->op_private & OPpDEREF)
 404             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
 405     }
 406     SETs(sv);
 407     RETURN;
 408 }
 409
 410 PP(pp_av2arylen)
 411 {
 412     dSP;
 413     AV * const av = MUTABLE_AV(TOPs);
 414     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 415     if (lvalue) {
 416         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 417         if (!*svp) {
 418             *svp = newSV_type(SVt_PVMG);
 419             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 420         }
 421         SETs(*svp);
 422     } else {
 423         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
 424     }
 425     RETURN;
 426 }
 427
 428 PP(pp_pos)
 429 {
 430     dSP; dTOPss;
 431
 432     if (PL_op->op_flags & OPf_MOD || LVRET) {
 433         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
 434         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 435         LvTYPE(ret) = '.';
 436         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 437         SETs(ret);    /* no SvSETMAGIC */
 438     }
 439     else {
 440             const MAGIC * const mg = mg_find_mglob(sv);
 441             if (mg && mg->mg_len != -1) {
 442                 dTARGET;
 443                 STRLEN i = mg->mg_len;
 444                 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
 445                     i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
 446                 SETu(i);
 447                 return NORMAL;
 448             }
 449             SETs(&PL_sv_undef);
 450     }
 451     return NORMAL;
 452 }
 453
 454 PP(pp_rv2cv)
 455 {
 456     dSP;
 457     GV *gv;
 458     HV *stash_unused;
 459     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 460         ? GV_ADDMG
 461         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
 462                                                     == OPpMAY_RETURN_CONSTANT)
 463             ? GV_ADD|GV_NOEXPAND
 464             : GV_ADD;
 465     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 466     /* (But not in defined().) */
 467
 468     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 469     if (cv) NOOP;
 470     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 471         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
 472             ? MUTABLE_CV(SvRV(gv))
 473             : MUTABLE_CV(gv);
 474     }
 475     else
 476         cv = MUTABLE_CV(&PL_sv_undef);
 477     SETs(MUTABLE_SV(cv));
 478     return NORMAL;
 479 }
 480
 481 PP(pp_prototype)
 482 {
 483     dSP;
 484     CV *cv;
 485     HV *stash;
 486     GV *gv;
 487     SV *ret = &PL_sv_undef;
 488
 489     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
 490     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 491         const char * s = SvPVX_const(TOPs);
 492         if (strnEQ(s, "CORE::", 6)) {
 493             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 494             if (!code)
 495                 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
 496                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
 497             {
 498                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 499                 if (sv) ret = sv;
 500             }
 501             goto set;
 502         }
 503     }
 504     cv = sv_2cv(TOPs, &stash, &gv, 0);
 505     if (cv && SvPOK(cv))
 506         ret = newSVpvn_flags(
 507             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 508         );
 509   set:
 510     SETs(ret);
 511     RETURN;
 512 }
 513
 514 PP(pp_anoncode)
 515 {
 516     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     dSP;
 528     *SP = refto(*SP);
 529     return NORMAL;
 530 }
 531
 532 PP(pp_refgen)
 533 {
 534     dSP; dMARK;
 535     if (GIMME_V != G_ARRAY) {
 536         if (++MARK <= SP)
 537             *MARK = *SP;
 538         else
 539         {
 540             MEXTEND(SP, 1);
 541             *MARK = &PL_sv_undef;
 542         }
 543         *MARK = refto(*MARK);
 544         SP = MARK;
 545         RETURN;
 546     }
 547     EXTEND_MORTAL(SP - MARK);
 548     while (++MARK <= SP)
 549         *MARK = refto(*MARK);
 550     RETURN;
 551 }
 552
 553 STATIC SV*
 554 S_refto(pTHX_ SV *sv)
 555 {
 556     SV* rv;
 557
 558     PERL_ARGS_ASSERT_REFTO;
 559
 560     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 561         if (LvTARGLEN(sv))
 562             vivify_defelem(sv);
 563         if (!(sv = LvTARG(sv)))
 564             sv = &PL_sv_undef;
 565         else
 566             SvREFCNT_inc_void_NN(sv);
 567     }
 568     else if (SvTYPE(sv) == SVt_PVAV) {
 569         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 570             av_reify(MUTABLE_AV(sv));
 571         SvTEMP_off(sv);
 572         SvREFCNT_inc_void_NN(sv);
 573     }
 574     else if (SvPADTMP(sv)) {
 575         sv = newSVsv(sv);
 576     }
 577     else {
 578         SvTEMP_off(sv);
 579         SvREFCNT_inc_void_NN(sv);
 580     }
 581     rv = sv_newmortal();
 582     sv_upgrade(rv, SVt_IV);
 583     SvRV_set(rv, sv);
 584     SvROK_on(rv);
 585     return rv;
 586 }
 587
 588 PP(pp_ref)
 589 {
 590     dSP;
 591     SV * const sv = TOPs;
 592
 593     SvGETMAGIC(sv);
 594     if (!SvROK(sv))
 595         SETs(&PL_sv_no);
 596     else {
 597         dTARGET;
 598         SETs(TARG);
 599         /* use the return value that is in a register, its the same as TARG */
 600         TARG = sv_ref(TARG,SvRV(sv),TRUE);
 601         SvSETMAGIC(TARG);
 602     }
 603
 604     return NORMAL;
 605 }
 606
 607 PP(pp_bless)
 608 {
 609     dSP;
 610     HV *stash;
 611
 612     if (MAXARG == 1)
 613     {
 614       curstash:
 615         stash = CopSTASH(PL_curcop);
 616         if (SvTYPE(stash) != SVt_PVHV)
 617             Perl_croak(aTHX_ "Attempt to bless into a freed package");
 618     }
 619     else {
 620         SV * const ssv = POPs;
 621         STRLEN len;
 622         const char *ptr;
 623
 624         if (!ssv) goto curstash;
 625         SvGETMAGIC(ssv);
 626         if (SvROK(ssv)) {
 627           if (!SvAMAGIC(ssv)) {
 628            frog:
 629             Perl_croak(aTHX_ "Attempt to bless into a reference");
 630           }
 631           /* SvAMAGIC is on here, but it only means potentially overloaded,
 632              so after stringification: */
 633           ptr = SvPV_nomg_const(ssv,len);
 634           /* We need to check the flag again: */
 635           if (!SvAMAGIC(ssv)) goto frog;
 636         }
 637         else ptr = SvPV_nomg_const(ssv,len);
 638         if (len == 0)
 639             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 640                            "Explicit blessing to '' (assuming package main)");
 641         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 642     }
 643
 644     (void)sv_bless(TOPs, stash);
 645     RETURN;
 646 }
 647
 648 PP(pp_gelem)
 649 {
 650     dSP;
 651
 652     SV *sv = POPs;
 653     STRLEN len;
 654     const char * const elem = SvPV_const(sv, len);
 655     GV * const gv = MUTABLE_GV(TOPs);
 656     SV * tmpRef = NULL;
 657
 658     sv = NULL;
 659     if (elem) {
 660         /* elem will always be NUL terminated.  */
 661         const char * const second_letter = elem + 1;
 662         switch (*elem) {
 663         case 'A':
 664             if (len == 5 && strEQ(second_letter, "RRAY"))
 665             {
 666                 tmpRef = MUTABLE_SV(GvAV(gv));
 667                 if (tmpRef && !AvREAL((const AV *)tmpRef)
 668                  && AvREIFY((const AV *)tmpRef))
 669                     av_reify(MUTABLE_AV(tmpRef));
 670             }
 671             break;
 672         case 'C':
 673             if (len == 4 && strEQ(second_letter, "ODE"))
 674                 tmpRef = MUTABLE_SV(GvCVu(gv));
 675             break;
 676         case 'F':
 677             if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
 678                 /* finally deprecated in 5.8.0 */
 679                 deprecate("*glob{FILEHANDLE}");
 680                 tmpRef = MUTABLE_SV(GvIOp(gv));
 681             }
 682             else
 683                 if (len == 6 && strEQ(second_letter, "ORMAT"))
 684                     tmpRef = MUTABLE_SV(GvFORM(gv));
 685             break;
 686         case 'G':
 687             if (len == 4 && strEQ(second_letter, "LOB"))
 688                 tmpRef = MUTABLE_SV(gv);
 689             break;
 690         case 'H':
 691             if (len == 4 && strEQ(second_letter, "ASH"))
 692                 tmpRef = MUTABLE_SV(GvHV(gv));
 693             break;
 694         case 'I':
 695             if (*second_letter == 'O' && !elem[2] && len == 2)
 696                 tmpRef = MUTABLE_SV(GvIOp(gv));
 697             break;
 698         case 'N':
 699             if (len == 4 && strEQ(second_letter, "AME"))
 700                 sv = newSVhek(GvNAME_HEK(gv));
 701             break;
 702         case 'P':
 703             if (len == 7 && strEQ(second_letter, "ACKAGE")) {
 704                 const HV * const stash = GvSTASH(gv);
 705                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 706                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 707             }
 708             break;
 709         case 'S':
 710             if (len == 6 && strEQ(second_letter, "CALAR"))
 711                 tmpRef = GvSVn(gv);
 712             break;
 713         }
 714     }
 715     if (tmpRef)
 716         sv = newRV(tmpRef);
 717     if (sv)
 718         sv_2mortal(sv);
 719     else
 720         sv = &PL_sv_undef;
 721     SETs(sv);
 722     RETURN;
 723 }
 724
 725 /* Pattern matching */
 726
 727 PP(pp_study)
 728 {
 729     dSP; dTOPss;
 730     STRLEN len;
 731
 732     (void)SvPV(sv, len);
 733     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 734         /* Historically, study was skipped in these cases. */
 735         SETs(&PL_sv_no);
 736         return NORMAL;
 737     }
 738
 739     /* Make study a no-op. It's no longer useful and its existence
 740        complicates matters elsewhere. */
 741     SETs(&PL_sv_yes);
 742     return NORMAL;
 743 }
 744
 745
 746 /* also used for: pp_transr() */
 747
 748 PP(pp_trans)
 749 {
 750     dSP;
 751     SV *sv;
 752
 753     if (PL_op->op_flags & OPf_STACKED)
 754         sv = POPs;
 755     else {
 756         EXTEND(SP,1);
 757         if (ARGTARG)
 758             sv = PAD_SV(ARGTARG);
 759         else {
 760             sv = DEFSV;
 761         }
 762     }
 763     if(PL_op->op_type == OP_TRANSR) {
 764         STRLEN len;
 765         const char * const pv = SvPV(sv,len);
 766         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 767         do_trans(newsv);
 768         PUSHs(newsv);
 769     }
 770     else {
 771         I32 i = do_trans(sv);
 772         mPUSHi(i);
 773     }
 774     RETURN;
 775 }
 776
 777 /* Lvalue operators. */
 778
 779 static size_t
 780 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 781 {
 782     STRLEN len;
 783     char *s;
 784     size_t count = 0;
 785
 786     PERL_ARGS_ASSERT_DO_CHOMP;
 787
 788     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 789         return 0;
 790     if (SvTYPE(sv) == SVt_PVAV) {
 791         I32 i;
 792         AV *const av = MUTABLE_AV(sv);
 793         const I32 max = AvFILL(av);
 794
 795         for (i = 0; i <= max; i++) {
 796             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 797             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 798                 count += do_chomp(retval, sv, chomping);
 799         }
 800         return count;
 801     }
 802     else if (SvTYPE(sv) == SVt_PVHV) {
 803         HV* const hv = MUTABLE_HV(sv);
 804         HE* entry;
 805         (void)hv_iterinit(hv);
 806         while ((entry = hv_iternext(hv)))
 807             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
 808         return count;
 809     }
 810     else if (SvREADONLY(sv)) {
 811             Perl_croak_no_modify();
 812     }
 813
 814     if (IN_ENCODING) {
 815         if (!SvUTF8(sv)) {
 816             /* XXX, here sv is utf8-ized as a side-effect!
 817                If encoding.pm is used properly, almost string-generating
 818                operations, including literal strings, chr(), input data, etc.
 819                should have been utf8-ized already, right?
 820             */
 821             sv_recode_to_utf8(sv, _get_encoding());
 822         }
 823     }
 824
 825     s = SvPV(sv, len);
 826     if (chomping) {
 827         if (s && len) {
 828             char *temp_buffer = NULL;
 829             SV *svrecode = NULL;
 830             s += --len;
 831             if (RsPARA(PL_rs)) {
 832                 if (*s != '\n')
 833                     goto nope_free_nothing;
 834                 ++count;
 835                 while (len && s[-1] == '\n') {
 836                     --len;
 837                     --s;
 838                     ++count;
 839                 }
 840             }
 841             else {
 842                 STRLEN rslen, rs_charlen;
 843                 const char *rsptr = SvPV_const(PL_rs, rslen);
 844
 845                 rs_charlen = SvUTF8(PL_rs)
 846                     ? sv_len_utf8(PL_rs)
 847                     : rslen;
 848
 849                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 850                     /* Assumption is that rs is shorter than the scalar.  */
 851                     if (SvUTF8(PL_rs)) {
 852                         /* RS is utf8, scalar is 8 bit.  */
 853                         bool is_utf8 = TRUE;
 854                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 855                                                              &rslen, &is_utf8);
 856                         if (is_utf8) {
 857                             /* Cannot downgrade, therefore cannot possibly match.
 858                                At this point, temp_buffer is not alloced, and
 859                                is the buffer inside PL_rs, so dont free it.
 860                              */
 861                             assert (temp_buffer == rsptr);
 862                             goto nope_free_sv;
 863                         }
 864                         rsptr = temp_buffer;
 865                     }
 866                     else if (IN_ENCODING) {
 867                         /* RS is 8 bit, encoding.pm is used.
 868                          * Do not recode PL_rs as a side-effect. */
 869                         svrecode = newSVpvn(rsptr, rslen);
 870                         sv_recode_to_utf8(svrecode, _get_encoding());
 871                         rsptr = SvPV_const(svrecode, rslen);
 872                         rs_charlen = sv_len_utf8(svrecode);
 873                     }
 874                     else {
 875                         /* RS is 8 bit, scalar is utf8.  */
 876                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 877                         rsptr = temp_buffer;
 878                     }
 879                 }
 880                 if (rslen == 1) {
 881                     if (*s != *rsptr)
 882                         goto nope_free_all;
 883                     ++count;
 884                 }
 885                 else {
 886                     if (len < rslen - 1)
 887                         goto nope_free_all;
 888                     len -= rslen - 1;
 889                     s -= rslen - 1;
 890                     if (memNE(s, rsptr, rslen))
 891                         goto nope_free_all;
 892                     count += rs_charlen;
 893                 }
 894             }
 895             SvPV_force_nomg_nolen(sv);
 896             SvCUR_set(sv, len);
 897             *SvEND(sv) = '\0';
 898             SvNIOK_off(sv);
 899             SvSETMAGIC(sv);
 900
 901             nope_free_all:
 902             Safefree(temp_buffer);
 903             nope_free_sv:
 904             SvREFCNT_dec(svrecode);
 905             nope_free_nothing: ;
 906         }
 907     } else {
 908         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
 909             s = SvPV_force_nomg(sv, len);
 910         if (DO_UTF8(sv)) {
 911             if (s && len) {
 912                 char * const send = s + len;
 913                 char * const start = s;
 914                 s = send - 1;
 915                 while (s > start && UTF8_IS_CONTINUATION(*s))
 916                     s--;
 917                 if (is_utf8_string((U8*)s, send - s)) {
 918                     sv_setpvn(retval, s, send - s);
 919                     *s = '\0';
 920                     SvCUR_set(sv, s - start);
 921                     SvNIOK_off(sv);
 922                     SvUTF8_on(retval);
 923                 }
 924             }
 925             else
 926                 sv_setpvs(retval, "");
 927         }
 928         else if (s && len) {
 929             s += --len;
 930             sv_setpvn(retval, s, 1);
 931             *s = '\0';
 932             SvCUR_set(sv, len);
 933             SvUTF8_off(sv);
 934             SvNIOK_off(sv);
 935         }
 936         else
 937             sv_setpvs(retval, "");
 938         SvSETMAGIC(sv);
 939     }
 940     return count;
 941 }
 942
 943
 944 /* also used for: pp_schomp() */
 945
 946 PP(pp_schop)
 947 {
 948     dSP; dTARGET;
 949     const bool chomping = PL_op->op_type == OP_SCHOMP;
 950
 951     const size_t count = do_chomp(TARG, TOPs, chomping);
 952     if (chomping)
 953         sv_setiv(TARG, count);
 954     SETTARG;
 955     return NORMAL;
 956 }
 957
 958
 959 /* also used for: pp_chomp() */
 960
 961 PP(pp_chop)
 962 {
 963     dSP; dMARK; dTARGET; dORIGMARK;
 964     const bool chomping = PL_op->op_type == OP_CHOMP;
 965     size_t count = 0;
 966
 967     while (MARK < SP)
 968         count += do_chomp(TARG, *++MARK, chomping);
 969     if (chomping)
 970         sv_setiv(TARG, count);
 971     SP = ORIGMARK;
 972     XPUSHTARG;
 973     RETURN;
 974 }
 975
 976 PP(pp_undef)
 977 {
 978     dSP;
 979     SV *sv;
 980
 981     if (!PL_op->op_private) {
 982         EXTEND(SP, 1);
 983         RETPUSHUNDEF;
 984     }
 985
 986     sv = TOPs;
 987     if (!sv)
 988     {
 989         SETs(&PL_sv_undef);
 990         return NORMAL;
 991     }
 992
 993     if (SvTHINKFIRST(sv))
 994         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
 995
 996     switch (SvTYPE(sv)) {
 997     case SVt_NULL:
 998         break;
 999     case SVt_PVAV:
1000         av_undef(MUTABLE_AV(sv));
1001         break;
1002     case SVt_PVHV:
1003         hv_undef(MUTABLE_HV(sv));
1004         break;
1005     case SVt_PVCV:
1006         if (cv_const_sv((const CV *)sv))
1007             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1008                           "Constant subroutine %"SVf" undefined",
1009                            SVfARG(CvANON((const CV *)sv)
1010                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1011                              : sv_2mortal(newSVhek(
1012                                 CvNAMED(sv)
1013                                  ? CvNAME_HEK((CV *)sv)
1014                                  : GvENAME_HEK(CvGV((const CV *)sv))
1015                                ))
1016                            ));
1017         /* FALLTHROUGH */
1018     case SVt_PVFM:
1019             /* let user-undef'd sub keep its identity */
1020         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1021         break;
1022     case SVt_PVGV:
1023         assert(isGV_with_GP(sv));
1024         assert(!SvFAKE(sv));
1025         {
1026             GP *gp;
1027             HV *stash;
1028
1029             /* undef *Pkg::meth_name ... */
1030             bool method_changed
1031              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1032               && HvENAME_get(stash);
1033             /* undef *Foo:: */
1034             if((stash = GvHV((const GV *)sv))) {
1035                 if(HvENAME_get(stash))
1036                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1037                 else stash = NULL;
1038             }
1039
1040             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1041             gp_free(MUTABLE_GV(sv));
1042             Newxz(gp, 1, GP);
1043             GvGP_set(sv, gp_ref(gp));
1044 #ifndef PERL_DONT_CREATE_GVSV
1045             GvSV(sv) = newSV(0);
1046 #endif
1047             GvLINE(sv) = CopLINE(PL_curcop);
1048             GvEGV(sv) = MUTABLE_GV(sv);
1049             GvMULTI_on(sv);
1050
1051             if(stash)
1052                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1053             stash = NULL;
1054             /* undef *Foo::ISA */
1055             if( strEQ(GvNAME((const GV *)sv), "ISA")
1056              && (stash = GvSTASH((const GV *)sv))
1057              && (method_changed || HvENAME(stash)) )
1058                 mro_isa_changed_in(stash);
1059             else if(method_changed)
1060                 mro_method_changed_in(
1061                  GvSTASH((const GV *)sv)
1062                 );
1063
1064             break;
1065         }
1066     default:
1067         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1068             SvPV_free(sv);
1069             SvPV_set(sv, NULL);
1070             SvLEN_set(sv, 0);
1071         }
1072         SvOK_off(sv);
1073         SvSETMAGIC(sv);
1074     }
1075
1076     SETs(&PL_sv_undef);
1077     return NORMAL;
1078 }
1079
1080
1081 /* common "slow" code for pp_postinc and pp_postdec */
1082
1083 static OP *
1084 S_postincdec_common(pTHX_ SV *sv, SV *targ)
1085 {
1086     dSP;
1087     const bool inc =
1088         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1089
1090     if (SvROK(sv))
1091         TARG = sv_newmortal();
1092     sv_setsv(TARG, sv);
1093     if (inc)
1094         sv_inc_nomg(sv);
1095     else
1096         sv_dec_nomg(sv);
1097     SvSETMAGIC(sv);
1098     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1099     if (inc && !SvOK(TARG))
1100         sv_setiv(TARG, 0);
1101     SETTARG;
1102     return NORMAL;
1103 }
1104
1105
1106 /* also used for: pp_i_postinc() */
1107
1108 PP(pp_postinc)
1109 {
1110     dSP; dTARGET;
1111     SV *sv = TOPs;
1112
1113     /* special-case sv being a simple integer */
1114     if (LIKELY(((sv->sv_flags &
1115                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1116                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1117                 == SVf_IOK))
1118         && SvIVX(sv) != IV_MAX)
1119     {
1120         IV iv = SvIVX(sv);
1121         SvIV_set(sv,  iv + 1);
1122         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1123         SETs(TARG);
1124         return NORMAL;
1125     }
1126
1127     return S_postincdec_common(aTHX_ sv, TARG);
1128 }
1129
1130
1131 /* also used for: pp_i_postdec() */
1132
1133 PP(pp_postdec)
1134 {
1135     dSP; dTARGET;
1136     SV *sv = TOPs;
1137
1138     /* special-case sv being a simple integer */
1139     if (LIKELY(((sv->sv_flags &
1140                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1141                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1142                 == SVf_IOK))
1143         && SvIVX(sv) != IV_MIN)
1144     {
1145         IV iv = SvIVX(sv);
1146         SvIV_set(sv,  iv - 1);
1147         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1148         SETs(TARG);
1149         return NORMAL;
1150     }
1151
1152     return S_postincdec_common(aTHX_ sv, TARG);
1153 }
1154
1155
1156 /* Ordinary operators. */
1157
1158 PP(pp_pow)
1159 {
1160     dSP; dATARGET; SV *svl, *svr;
1161 #ifdef PERL_PRESERVE_IVUV
1162     bool is_int = 0;
1163 #endif
1164     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1165     svr = TOPs;
1166     svl = TOPm1s;
1167 #ifdef PERL_PRESERVE_IVUV
1168     /* For integer to integer power, we do the calculation by hand wherever
1169        we're sure it is safe; otherwise we call pow() and try to convert to
1170        integer afterwards. */
1171     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1172                 UV power;
1173                 bool baseuok;
1174                 UV baseuv;
1175
1176                 if (SvUOK(svr)) {
1177                     power = SvUVX(svr);
1178                 } else {
1179                     const IV iv = SvIVX(svr);
1180                     if (iv >= 0) {
1181                         power = iv;
1182                     } else {
1183                         goto float_it; /* Can't do negative powers this way.  */
1184                     }
1185                 }
1186
1187                 baseuok = SvUOK(svl);
1188                 if (baseuok) {
1189                     baseuv = SvUVX(svl);
1190                 } else {
1191                     const IV iv = SvIVX(svl);
1192                     if (iv >= 0) {
1193                         baseuv = iv;
1194                         baseuok = TRUE; /* effectively it's a UV now */
1195                     } else {
1196                         baseuv = -iv; /* abs, baseuok == false records sign */
1197                     }
1198                 }
1199                 /* now we have integer ** positive integer. */
1200                 is_int = 1;
1201
1202                 /* foo & (foo - 1) is zero only for a power of 2.  */
1203                 if (!(baseuv & (baseuv - 1))) {
1204                     /* We are raising power-of-2 to a positive integer.
1205                        The logic here will work for any base (even non-integer
1206                        bases) but it can be less accurate than
1207                        pow (base,power) or exp (power * log (base)) when the
1208                        intermediate values start to spill out of the mantissa.
1209                        With powers of 2 we know this can't happen.
1210                        And powers of 2 are the favourite thing for perl
1211                        programmers to notice ** not doing what they mean. */
1212                     NV result = 1.0;
1213                     NV base = baseuok ? baseuv : -(NV)baseuv;
1214
1215                     if (power & 1) {
1216                         result *= base;
1217                     }
1218                     while (power >>= 1) {
1219                         base *= base;
1220                         if (power & 1) {
1221                             result *= base;
1222                         }
1223                     }
1224                     SP--;
1225                     SETn( result );
1226                     SvIV_please_nomg(svr);
1227                     RETURN;
1228                 } else {
1229                     unsigned int highbit = 8 * sizeof(UV);
1230                     unsigned int diff = 8 * sizeof(UV);
1231                     while (diff >>= 1) {
1232                         highbit -= diff;
1233                         if (baseuv >> highbit) {
1234                             highbit += diff;
1235                         }
1236                     }
1237                     /* we now have baseuv < 2 ** highbit */
1238                     if (power * highbit <= 8 * sizeof(UV)) {
1239                         /* result will definitely fit in UV, so use UV math
1240                            on same algorithm as above */
1241                         UV result = 1;
1242                         UV base = baseuv;
1243                         const bool odd_power = cBOOL(power & 1);
1244                         if (odd_power) {
1245                             result *= base;
1246                         }
1247                         while (power >>= 1) {
1248                             base *= base;
1249                             if (power & 1) {
1250                                 result *= base;
1251                             }
1252                         }
1253                         SP--;
1254                         if (baseuok || !odd_power)
1255                             /* answer is positive */
1256                             SETu( result );
1257                         else if (result <= (UV)IV_MAX)
1258                             /* answer negative, fits in IV */
1259                             SETi( -(IV)result );
1260                         else if (result == (UV)IV_MIN)
1261                             /* 2's complement assumption: special case IV_MIN */
1262                             SETi( IV_MIN );
1263                         else
1264                             /* answer negative, doesn't fit */
1265                             SETn( -(NV)result );
1266                         RETURN;
1267                     }
1268                 }
1269     }
1270   float_it:
1271 #endif
1272     {
1273         NV right = SvNV_nomg(svr);
1274         NV left  = SvNV_nomg(svl);
1275         (void)POPs;
1276
1277 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1278     /*
1279     We are building perl with long double support and are on an AIX OS
1280     afflicted with a powl() function that wrongly returns NaNQ for any
1281     negative base.  This was reported to IBM as PMR #23047-379 on
1282     03/06/2006.  The problem exists in at least the following versions
1283     of AIX and the libm fileset, and no doubt others as well:
1284
1285         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1286         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1287         AIX 5.2.0           bos.adt.libm 5.2.0.85
1288
1289     So, until IBM fixes powl(), we provide the following workaround to
1290     handle the problem ourselves.  Our logic is as follows: for
1291     negative bases (left), we use fmod(right, 2) to check if the
1292     exponent is an odd or even integer:
1293
1294         - if odd,  powl(left, right) == -powl(-left, right)
1295         - if even, powl(left, right) ==  powl(-left, right)
1296
1297     If the exponent is not an integer, the result is rightly NaNQ, so
1298     we just return that (as NV_NAN).
1299     */
1300
1301         if (left < 0.0) {
1302             NV mod2 = Perl_fmod( right, 2.0 );
1303             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1304                 SETn( -Perl_pow( -left, right) );
1305             } else if (mod2 == 0.0) {           /* even integer */
1306                 SETn( Perl_pow( -left, right) );
1307             } else {                            /* fractional power */
1308                 SETn( NV_NAN );
1309             }
1310         } else {
1311             SETn( Perl_pow( left, right) );
1312         }
1313 #else
1314         SETn( Perl_pow( left, right) );
1315 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1316
1317 #ifdef PERL_PRESERVE_IVUV
1318         if (is_int)
1319             SvIV_please_nomg(svr);
1320 #endif
1321         RETURN;
1322     }
1323 }
1324
1325 PP(pp_multiply)
1326 {
1327     dSP; dATARGET; SV *svl, *svr;
1328     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1329     svr = TOPs;
1330     svl = TOPm1s;
1331
1332 #ifdef PERL_PRESERVE_IVUV
1333
1334     /* special-case some simple common cases */
1335     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1336         IV il, ir;
1337         U32 flags = (svl->sv_flags & svr->sv_flags);
1338         if (flags & SVf_IOK) {
1339             /* both args are simple IVs */
1340             UV topl, topr;
1341             il = SvIVX(svl);
1342             ir = SvIVX(svr);
1343           do_iv:
1344             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1345             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1346
1347             /* if both are in a range that can't under/overflow, do a
1348              * simple integer multiply: if the top halves(*) of both numbers
1349              * are 00...00  or 11...11, then it's safe.
1350              * (*) for 32-bits, the "top half" is the top 17 bits,
1351              *     for 64-bits, its 33 bits */
1352             if (!(
1353                       ((topl+1) | (topr+1))
1354                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1355             )) {
1356                 SP--;
1357                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1358                 SETs(TARG);
1359                 RETURN;
1360             }
1361             goto generic;
1362         }
1363         else if (flags & SVf_NOK) {
1364             /* both args are NVs */
1365             NV nl = SvNVX(svl);
1366             NV nr = SvNVX(svr);
1367             NV result;
1368
1369             il = (IV)nl;
1370             ir = (IV)nr;
1371             if (nl == (NV)il && nr == (NV)ir)
1372                 /* nothing was lost by converting to IVs */
1373                 goto do_iv;
1374             SP--;
1375             result = nl * nr;
1376 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1377             if (Perl_isinf(result)) {
1378                 Zero((U8*)&result + 8, 8, U8);
1379             }
1380 #  endif
1381             TARGn(result, 0); /* args not GMG, so can't be tainted */
1382             SETs(TARG);
1383             RETURN;
1384         }
1385     }
1386
1387   generic:
1388
1389     if (SvIV_please_nomg(svr)) {
1390         /* Unless the left argument is integer in range we are going to have to
1391            use NV maths. Hence only attempt to coerce the right argument if
1392            we know the left is integer.  */
1393         /* Left operand is defined, so is it IV? */
1394         if (SvIV_please_nomg(svl)) {
1395             bool auvok = SvUOK(svl);
1396             bool buvok = SvUOK(svr);
1397             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1398             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1399             UV alow;
1400             UV ahigh;
1401             UV blow;
1402             UV bhigh;
1403
1404             if (auvok) {
1405                 alow = SvUVX(svl);
1406             } else {
1407                 const IV aiv = SvIVX(svl);
1408                 if (aiv >= 0) {
1409                     alow = aiv;
1410                     auvok = TRUE; /* effectively it's a UV now */
1411                 } else {
1412                     /* abs, auvok == false records sign */
1413                     alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1414                 }
1415             }
1416             if (buvok) {
1417                 blow = SvUVX(svr);
1418             } else {
1419                 const IV biv = SvIVX(svr);
1420                 if (biv >= 0) {
1421                     blow = biv;
1422                     buvok = TRUE; /* effectively it's a UV now */
1423                 } else {
1424                     /* abs, buvok == false records sign */
1425                     blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1426                 }
1427             }
1428
1429             /* If this does sign extension on unsigned it's time for plan B  */
1430             ahigh = alow >> (4 * sizeof (UV));
1431             alow &= botmask;
1432             bhigh = blow >> (4 * sizeof (UV));
1433             blow &= botmask;
1434             if (ahigh && bhigh) {
1435                 NOOP;
1436                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1437                    which is overflow. Drop to NVs below.  */
1438             } else if (!ahigh && !bhigh) {
1439                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1440                    so the unsigned multiply cannot overflow.  */
1441                 const UV product = alow * blow;
1442                 if (auvok == buvok) {
1443                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1444                     SP--;
1445                     SETu( product );
1446                     RETURN;
1447                 } else if (product <= (UV)IV_MIN) {
1448                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1449                     /* -ve result, which could overflow an IV  */
1450                     SP--;
1451                     /* can't negate IV_MIN, but there are aren't two
1452                      * integers such that !ahigh && !bhigh, where the
1453                      * product equals 0x800....000 */
1454                     assert(product != (UV)IV_MIN);
1455                     SETi( -(IV)product );
1456                     RETURN;
1457                 } /* else drop to NVs below. */
1458             } else {
1459                 /* One operand is large, 1 small */
1460                 UV product_middle;
1461                 if (bhigh) {
1462                     /* swap the operands */
1463                     ahigh = bhigh;
1464                     bhigh = blow; /* bhigh now the temp var for the swap */
1465                     blow = alow;
1466                     alow = bhigh;
1467                 }
1468                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1469                    multiplies can't overflow. shift can, add can, -ve can.  */
1470                 product_middle = ahigh * blow;
1471                 if (!(product_middle & topmask)) {
1472                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1473                     UV product_low;
1474                     product_middle <<= (4 * sizeof (UV));
1475                     product_low = alow * blow;
1476
1477                     /* as for pp_add, UV + something mustn't get smaller.
1478                        IIRC ANSI mandates this wrapping *behaviour* for
1479                        unsigned whatever the actual representation*/
1480                     product_low += product_middle;
1481                     if (product_low >= product_middle) {
1482                         /* didn't overflow */
1483                         if (auvok == buvok) {
1484                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1485                             SP--;
1486                             SETu( product_low );
1487                             RETURN;
1488                         } else if (product_low <= (UV)IV_MIN) {
1489                             /* 2s complement assumption again  */
1490                             /* -ve result, which could overflow an IV  */
1491                             SP--;
1492                             SETi(product_low == (UV)IV_MIN
1493                                     ? IV_MIN : -(IV)product_low);
1494                             RETURN;
1495                         } /* else drop to NVs below. */
1496                     }
1497                 } /* product_middle too large */
1498             } /* ahigh && bhigh */
1499         } /* SvIOK(svl) */
1500     } /* SvIOK(svr) */
1501 #endif
1502     {
1503       NV right = SvNV_nomg(svr);
1504       NV left  = SvNV_nomg(svl);
1505       NV result = left * right;
1506
1507       (void)POPs;
1508 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1509       if (Perl_isinf(result)) {
1510           Zero((U8*)&result + 8, 8, U8);
1511       }
1512 #endif
1513       SETn(result);
1514       RETURN;
1515     }
1516 }
1517
1518 PP(pp_divide)
1519 {
1520     dSP; dATARGET; SV *svl, *svr;
1521     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1522     svr = TOPs;
1523     svl = TOPm1s;
1524     /* Only try to do UV divide first
1525        if ((SLOPPYDIVIDE is true) or
1526            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1527             to preserve))
1528        The assumption is that it is better to use floating point divide
1529        whenever possible, only doing integer divide first if we can't be sure.
1530        If NV_PRESERVES_UV is true then we know at compile time that no UV
1531        can be too large to preserve, so don't need to compile the code to
1532        test the size of UVs.  */
1533
1534 #ifdef SLOPPYDIVIDE
1535 #  define PERL_TRY_UV_DIVIDE
1536     /* ensure that 20./5. == 4. */
1537 #else
1538 #  ifdef PERL_PRESERVE_IVUV
1539 #    ifndef NV_PRESERVES_UV
1540 #      define PERL_TRY_UV_DIVIDE
1541 #    endif
1542 #  endif
1543 #endif
1544
1545 #ifdef PERL_TRY_UV_DIVIDE
1546     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1547             bool left_non_neg = SvUOK(svl);
1548             bool right_non_neg = SvUOK(svr);
1549             UV left;
1550             UV right;
1551
1552             if (right_non_neg) {
1553                 right = SvUVX(svr);
1554             }
1555             else {
1556                 const IV biv = SvIVX(svr);
1557                 if (biv >= 0) {
1558                     right = biv;
1559                     right_non_neg = TRUE; /* effectively it's a UV now */
1560                 }
1561                 else {
1562                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1563                 }
1564             }
1565             /* historically undef()/0 gives a "Use of uninitialized value"
1566                warning before dieing, hence this test goes here.
1567                If it were immediately before the second SvIV_please, then
1568                DIE() would be invoked before left was even inspected, so
1569                no inspection would give no warning.  */
1570             if (right == 0)
1571                 DIE(aTHX_ "Illegal division by zero");
1572
1573             if (left_non_neg) {
1574                 left = SvUVX(svl);
1575             }
1576             else {
1577                 const IV aiv = SvIVX(svl);
1578                 if (aiv >= 0) {
1579                     left = aiv;
1580                     left_non_neg = TRUE; /* effectively it's a UV now */
1581                 }
1582                 else {
1583                     left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1584                 }
1585             }
1586
1587             if (left >= right
1588 #ifdef SLOPPYDIVIDE
1589                 /* For sloppy divide we always attempt integer division.  */
1590 #else
1591                 /* Otherwise we only attempt it if either or both operands
1592                    would not be preserved by an NV.  If both fit in NVs
1593                    we fall through to the NV divide code below.  However,
1594                    as left >= right to ensure integer result here, we know that
1595                    we can skip the test on the right operand - right big
1596                    enough not to be preserved can't get here unless left is
1597                    also too big.  */
1598
1599                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1600 #endif
1601                 ) {
1602                 /* Integer division can't overflow, but it can be imprecise.  */
1603                 const UV result = left / right;
1604                 if (result * right == left) {
1605                     SP--; /* result is valid */
1606                     if (left_non_neg == right_non_neg) {
1607                         /* signs identical, result is positive.  */
1608                         SETu( result );
1609                         RETURN;
1610                     }
1611                     /* 2s complement assumption */
1612                     if (result <= (UV)IV_MIN)
1613                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1614                     else {
1615                         /* It's exact but too negative for IV. */
1616                         SETn( -(NV)result );
1617                     }
1618                     RETURN;
1619                 } /* tried integer divide but it was not an integer result */
1620             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1621     } /* one operand wasn't SvIOK */
1622 #endif /* PERL_TRY_UV_DIVIDE */
1623     {
1624         NV right = SvNV_nomg(svr);
1625         NV left  = SvNV_nomg(svl);
1626         (void)POPs;(void)POPs;
1627 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1628         if (! Perl_isnan(right) && right == 0.0)
1629 #else
1630         if (right == 0.0)
1631 #endif
1632             DIE(aTHX_ "Illegal division by zero");
1633         PUSHn( left / right );
1634         RETURN;
1635     }
1636 }
1637
1638 PP(pp_modulo)
1639 {
1640     dSP; dATARGET;
1641     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1642     {
1643         UV left  = 0;
1644         UV right = 0;
1645         bool left_neg = FALSE;
1646         bool right_neg = FALSE;
1647         bool use_double = FALSE;
1648         bool dright_valid = FALSE;
1649         NV dright = 0.0;
1650         NV dleft  = 0.0;
1651         SV * const svr = TOPs;
1652         SV * const svl = TOPm1s;
1653         if (SvIV_please_nomg(svr)) {
1654             right_neg = !SvUOK(svr);
1655             if (!right_neg) {
1656                 right = SvUVX(svr);
1657             } else {
1658                 const IV biv = SvIVX(svr);
1659                 if (biv >= 0) {
1660                     right = biv;
1661                     right_neg = FALSE; /* effectively it's a UV now */
1662                 } else {
1663                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1664                 }
1665             }
1666         }
1667         else {
1668             dright = SvNV_nomg(svr);
1669             right_neg = dright < 0;
1670             if (right_neg)
1671                 dright = -dright;
1672             if (dright < UV_MAX_P1) {
1673                 right = U_V(dright);
1674                 dright_valid = TRUE; /* In case we need to use double below.  */
1675             } else {
1676                 use_double = TRUE;
1677             }
1678         }
1679
1680         /* At this point use_double is only true if right is out of range for
1681            a UV.  In range NV has been rounded down to nearest UV and
1682            use_double false.  */
1683         if (!use_double && SvIV_please_nomg(svl)) {
1684                 left_neg = !SvUOK(svl);
1685                 if (!left_neg) {
1686                     left = SvUVX(svl);
1687                 } else {
1688                     const IV aiv = SvIVX(svl);
1689                     if (aiv >= 0) {
1690                         left = aiv;
1691                         left_neg = FALSE; /* effectively it's a UV now */
1692                     } else {
1693                         left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1694                     }
1695                 }
1696         }
1697         else {
1698             dleft = SvNV_nomg(svl);
1699             left_neg = dleft < 0;
1700             if (left_neg)
1701                 dleft = -dleft;
1702
1703             /* This should be exactly the 5.6 behaviour - if left and right are
1704                both in range for UV then use U_V() rather than floor.  */
1705             if (!use_double) {
1706                 if (dleft < UV_MAX_P1) {
1707                     /* right was in range, so is dleft, so use UVs not double.
1708                      */
1709                     left = U_V(dleft);
1710                 }
1711                 /* left is out of range for UV, right was in range, so promote
1712                    right (back) to double.  */
1713                 else {
1714                     /* The +0.5 is used in 5.6 even though it is not strictly
1715                        consistent with the implicit +0 floor in the U_V()
1716                        inside the #if 1. */
1717                     dleft = Perl_floor(dleft + 0.5);
1718                     use_double = TRUE;
1719                     if (dright_valid)
1720                         dright = Perl_floor(dright + 0.5);
1721                     else
1722                         dright = right;
1723                 }
1724             }
1725         }
1726         sp -= 2;
1727         if (use_double) {
1728             NV dans;
1729
1730             if (!dright)
1731                 DIE(aTHX_ "Illegal modulus zero");
1732
1733             dans = Perl_fmod(dleft, dright);
1734             if ((left_neg != right_neg) && dans)
1735                 dans = dright - dans;
1736             if (right_neg)
1737                 dans = -dans;
1738             sv_setnv(TARG, dans);
1739         }
1740         else {
1741             UV ans;
1742
1743             if (!right)
1744                 DIE(aTHX_ "Illegal modulus zero");
1745
1746             ans = left % right;
1747             if ((left_neg != right_neg) && ans)
1748                 ans = right - ans;
1749             if (right_neg) {
1750                 /* XXX may warn: unary minus operator applied to unsigned type */
1751                 /* could change -foo to be (~foo)+1 instead     */
1752                 if (ans <= ~((UV)IV_MAX)+1)
1753                     sv_setiv(TARG, ~ans+1);
1754                 else
1755                     sv_setnv(TARG, -(NV)ans);
1756             }
1757             else
1758                 sv_setuv(TARG, ans);
1759         }
1760         PUSHTARG;
1761         RETURN;
1762     }
1763 }
1764
1765 PP(pp_repeat)
1766 {
1767     dSP; dATARGET;
1768     IV count;
1769     SV *sv;
1770     bool infnan = FALSE;
1771
1772     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1773         /* TODO: think of some way of doing list-repeat overloading ??? */
1774         sv = POPs;
1775         SvGETMAGIC(sv);
1776     }
1777     else {
1778         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1779             /* The parser saw this as a list repeat, and there
1780                are probably several items on the stack. But we're
1781                in scalar/void context, and there's no pp_list to save us
1782                now. So drop the rest of the items -- robin@kitsite.com
1783              */
1784             dMARK;
1785             if (MARK + 1 < SP) {
1786                 MARK[1] = TOPm1s;
1787                 MARK[2] = TOPs;
1788             }
1789             else {
1790                 dTOPss;
1791                 ASSUME(MARK + 1 == SP);
1792                 XPUSHs(sv);
1793                 MARK[1] = &PL_sv_undef;
1794             }
1795             SP = MARK + 2;
1796         }
1797         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1798         sv = POPs;
1799     }
1800
1801     if (SvIOKp(sv)) {
1802          if (SvUOK(sv)) {
1803               const UV uv = SvUV_nomg(sv);
1804               if (uv > IV_MAX)
1805                    count = IV_MAX; /* The best we can do? */
1806               else
1807                    count = uv;
1808          } else {
1809               count = SvIV_nomg(sv);
1810          }
1811     }
1812     else if (SvNOKp(sv)) {
1813         const NV nv = SvNV_nomg(sv);
1814         infnan = Perl_isinfnan(nv);
1815         if (UNLIKELY(infnan)) {
1816             count = 0;
1817         } else {
1818             if (nv < 0.0)
1819                 count = -1;   /* An arbitrary negative integer */
1820             else
1821                 count = (IV)nv;
1822         }
1823     }
1824     else
1825         count = SvIV_nomg(sv);
1826
1827     if (infnan) {
1828         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1829                        "Non-finite repeat count does nothing");
1830     } else if (count < 0) {
1831         count = 0;
1832         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1833                        "Negative repeat count does nothing");
1834     }
1835
1836     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1837         dMARK;
1838         const SSize_t items = SP - MARK;
1839         const U8 mod = PL_op->op_flags & OPf_MOD;
1840
1841         if (count > 1) {
1842             SSize_t max;
1843
1844             if (  items > SSize_t_MAX / count   /* max would overflow */
1845                                                 /* repeatcpy would overflow */
1846                || items > I32_MAX / (I32)sizeof(SV *)
1847             )
1848                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1849             max = items * count;
1850             MEXTEND(MARK, max);
1851
1852             while (SP > MARK) {
1853                 if (*SP) {
1854                    if (mod && SvPADTMP(*SP)) {
1855                        *SP = sv_mortalcopy(*SP);
1856                    }
1857                    SvTEMP_off((*SP));
1858                 }
1859                 SP--;
1860             }
1861             MARK++;
1862             repeatcpy((char*)(MARK + items), (char*)MARK,
1863                 items * sizeof(const SV *), count - 1);
1864             SP += max;
1865         }
1866         else if (count <= 0)
1867             SP = MARK;
1868     }
1869     else {      /* Note: mark already snarfed by pp_list */
1870         SV * const tmpstr = POPs;
1871         STRLEN len;
1872         bool isutf;
1873
1874         if (TARG != tmpstr)
1875             sv_setsv_nomg(TARG, tmpstr);
1876         SvPV_force_nomg(TARG, len);
1877         isutf = DO_UTF8(TARG);
1878         if (count != 1) {
1879             if (count < 1)
1880                 SvCUR_set(TARG, 0);
1881             else {
1882                 STRLEN max;
1883
1884                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1885                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1886                 )
1887                      Perl_croak(aTHX_ "%s",
1888                                         "Out of memory during string extend");
1889                 max = (UV)count * len + 1;
1890                 SvGROW(TARG, max);
1891
1892                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1893                 SvCUR_set(TARG, SvCUR(TARG) * count);
1894             }
1895             *SvEND(TARG) = '\0';
1896         }
1897         if (isutf)
1898             (void)SvPOK_only_UTF8(TARG);
1899         else
1900             (void)SvPOK_only(TARG);
1901
1902         PUSHTARG;
1903     }
1904     RETURN;
1905 }
1906
1907 PP(pp_subtract)
1908 {
1909     dSP; dATARGET; bool useleft; SV *svl, *svr;
1910     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1911     svr = TOPs;
1912     svl = TOPm1s;
1913
1914 #ifdef PERL_PRESERVE_IVUV
1915
1916     /* special-case some simple common cases */
1917     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1918         IV il, ir;
1919         U32 flags = (svl->sv_flags & svr->sv_flags);
1920         if (flags & SVf_IOK) {
1921             /* both args are simple IVs */
1922             UV topl, topr;
1923             il = SvIVX(svl);
1924             ir = SvIVX(svr);
1925           do_iv:
1926             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1927             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1928
1929             /* if both are in a range that can't under/overflow, do a
1930              * simple integer subtract: if the top of both numbers
1931              * are 00  or 11, then it's safe */
1932             if (!( ((topl+1) | (topr+1)) & 2)) {
1933                 SP--;
1934                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1935                 SETs(TARG);
1936                 RETURN;
1937             }
1938             goto generic;
1939         }
1940         else if (flags & SVf_NOK) {
1941             /* both args are NVs */
1942             NV nl = SvNVX(svl);
1943             NV nr = SvNVX(svr);
1944
1945             il = (IV)nl;
1946             ir = (IV)nr;
1947             if (nl == (NV)il && nr == (NV)ir)
1948                 /* nothing was lost by converting to IVs */
1949                 goto do_iv;
1950             SP--;
1951             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1952             SETs(TARG);
1953             RETURN;
1954         }
1955     }
1956
1957   generic:
1958
1959     useleft = USE_LEFT(svl);
1960     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1961        "bad things" happen if you rely on signed integers wrapping.  */
1962     if (SvIV_please_nomg(svr)) {
1963         /* Unless the left argument is integer in range we are going to have to
1964            use NV maths. Hence only attempt to coerce the right argument if
1965            we know the left is integer.  */
1966         UV auv = 0;
1967         bool auvok = FALSE;
1968         bool a_valid = 0;
1969
1970         if (!useleft) {
1971             auv = 0;
1972             a_valid = auvok = 1;
1973             /* left operand is undef, treat as zero.  */
1974         } else {
1975             /* Left operand is defined, so is it IV? */
1976             if (SvIV_please_nomg(svl)) {
1977                 if ((auvok = SvUOK(svl)))
1978                     auv = SvUVX(svl);
1979                 else {
1980                     const IV aiv = SvIVX(svl);
1981                     if (aiv >= 0) {
1982                         auv = aiv;
1983                         auvok = 1;      /* Now acting as a sign flag.  */
1984                     } else { /* 2s complement assumption for IV_MIN */
1985                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1986                     }
1987                 }
1988                 a_valid = 1;
1989             }
1990         }
1991         if (a_valid) {
1992             bool result_good = 0;
1993             UV result;
1994             UV buv;
1995             bool buvok = SvUOK(svr);
1996
1997             if (buvok)
1998                 buv = SvUVX(svr);
1999             else {
2000                 const IV biv = SvIVX(svr);
2001                 if (biv >= 0) {
2002                     buv = biv;
2003                     buvok = 1;
2004                 } else
2005                     buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
2006             }
2007             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
2008                else "IV" now, independent of how it came in.
2009                if a, b represents positive, A, B negative, a maps to -A etc
2010                a - b =>  (a - b)
2011                A - b => -(a + b)
2012                a - B =>  (a + b)
2013                A - B => -(a - b)
2014                all UV maths. negate result if A negative.
2015                subtract if signs same, add if signs differ. */
2016
2017             if (auvok ^ buvok) {
2018                 /* Signs differ.  */
2019                 result = auv + buv;
2020                 if (result >= auv)
2021                     result_good = 1;
2022             } else {
2023                 /* Signs same */
2024                 if (auv >= buv) {
2025                     result = auv - buv;
2026                     /* Must get smaller */
2027                     if (result <= auv)
2028                         result_good = 1;
2029                 } else {
2030                     result = buv - auv;
2031                     if (result <= buv) {
2032                         /* result really should be -(auv-buv). as its negation
2033                            of true value, need to swap our result flag  */
2034                         auvok = !auvok;
2035                         result_good = 1;
2036                     }
2037                 }
2038             }
2039             if (result_good) {
2040                 SP--;
2041                 if (auvok)
2042                     SETu( result );
2043                 else {
2044                     /* Negate result */
2045                     if (result <= (UV)IV_MIN)
2046                         SETi(result == (UV)IV_MIN
2047                                 ? IV_MIN : -(IV)result);
2048                     else {
2049                         /* result valid, but out of range for IV.  */
2050                         SETn( -(NV)result );
2051                     }
2052                 }
2053                 RETURN;
2054             } /* Overflow, drop through to NVs.  */
2055         }
2056     }
2057 #else
2058     useleft = USE_LEFT(svl);
2059 #endif
2060     {
2061         NV value = SvNV_nomg(svr);
2062         (void)POPs;
2063
2064         if (!useleft) {
2065             /* left operand is undef, treat as zero - value */
2066             SETn(-value);
2067             RETURN;
2068         }
2069         SETn( SvNV_nomg(svl) - value );
2070         RETURN;
2071     }
2072 }
2073
2074 #define IV_BITS (IVSIZE * 8)
2075
2076 static UV S_uv_shift(UV uv, int shift, bool left)
2077 {
2078    if (shift < 0) {
2079        shift = -shift;
2080        left = !left;
2081    }
2082    if (shift >= IV_BITS) {
2083        return 0;
2084    }
2085    return left ? uv << shift : uv >> shift;
2086 }
2087
2088 static IV S_iv_shift(IV iv, int shift, bool left)
2089 {
2090    if (shift < 0) {
2091        shift = -shift;
2092        left = !left;
2093    }
2094    if (shift >= IV_BITS) {
2095        return iv < 0 && !left ? -1 : 0;
2096    }
2097    return left ? iv << shift : iv >> shift;
2098 }
2099
2100 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2101 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2102 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2103 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2104
2105 PP(pp_left_shift)
2106 {
2107     dSP; dATARGET; SV *svl, *svr;
2108     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2109     svr = POPs;
2110     svl = TOPs;
2111     {
2112       const IV shift = SvIV_nomg(svr);
2113       if (PL_op->op_private & HINT_INTEGER) {
2114           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2115       }
2116       else {
2117           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2118       }
2119       RETURN;
2120     }
2121 }
2122
2123 PP(pp_right_shift)
2124 {
2125     dSP; dATARGET; SV *svl, *svr;
2126     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2127     svr = POPs;
2128     svl = TOPs;
2129     {
2130       const IV shift = SvIV_nomg(svr);
2131       if (PL_op->op_private & HINT_INTEGER) {
2132           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2133       }
2134       else {
2135           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2136       }
2137       RETURN;
2138     }
2139 }
2140
2141 PP(pp_lt)
2142 {
2143     dSP;
2144     SV *left, *right;
2145
2146     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2147     right = POPs;
2148     left  = TOPs;
2149     SETs(boolSV(
2150         (SvIOK_notUV(left) && SvIOK_notUV(right))
2151         ? (SvIVX(left) < SvIVX(right))
2152         : (do_ncmp(left, right) == -1)
2153     ));
2154     RETURN;
2155 }
2156
2157 PP(pp_gt)
2158 {
2159     dSP;
2160     SV *left, *right;
2161
2162     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2163     right = POPs;
2164     left  = TOPs;
2165     SETs(boolSV(
2166         (SvIOK_notUV(left) && SvIOK_notUV(right))
2167         ? (SvIVX(left) > SvIVX(right))
2168         : (do_ncmp(left, right) == 1)
2169     ));
2170     RETURN;
2171 }
2172
2173 PP(pp_le)
2174 {
2175     dSP;
2176     SV *left, *right;
2177
2178     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2179     right = POPs;
2180     left  = TOPs;
2181     SETs(boolSV(
2182         (SvIOK_notUV(left) && SvIOK_notUV(right))
2183         ? (SvIVX(left) <= SvIVX(right))
2184         : (do_ncmp(left, right) <= 0)
2185     ));
2186     RETURN;
2187 }
2188
2189 PP(pp_ge)
2190 {
2191     dSP;
2192     SV *left, *right;
2193
2194     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2195     right = POPs;
2196     left  = TOPs;
2197     SETs(boolSV(
2198         (SvIOK_notUV(left) && SvIOK_notUV(right))
2199         ? (SvIVX(left) >= SvIVX(right))
2200         : ( (do_ncmp(left, right) & 2) == 0)
2201     ));
2202     RETURN;
2203 }
2204
2205 PP(pp_ne)
2206 {
2207     dSP;
2208     SV *left, *right;
2209
2210     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2211     right = POPs;
2212     left  = TOPs;
2213     SETs(boolSV(
2214         (SvIOK_notUV(left) && SvIOK_notUV(right))
2215         ? (SvIVX(left) != SvIVX(right))
2216         : (do_ncmp(left, right) != 0)
2217     ));
2218     RETURN;
2219 }
2220
2221 /* compare left and right SVs. Returns:
2222  * -1: <
2223  *  0: ==
2224  *  1: >
2225  *  2: left or right was a NaN
2226  */
2227 I32
2228 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2229 {
2230     PERL_ARGS_ASSERT_DO_NCMP;
2231 #ifdef PERL_PRESERVE_IVUV
2232     /* Fortunately it seems NaN isn't IOK */
2233     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2234             if (!SvUOK(left)) {
2235                 const IV leftiv = SvIVX(left);
2236                 if (!SvUOK(right)) {
2237                     /* ## IV <=> IV ## */
2238                     const IV rightiv = SvIVX(right);
2239                     return (leftiv > rightiv) - (leftiv < rightiv);
2240                 }
2241                 /* ## IV <=> UV ## */
2242                 if (leftiv < 0)
2243                     /* As (b) is a UV, it's >=0, so it must be < */
2244                     return -1;
2245                 {
2246                     const UV rightuv = SvUVX(right);
2247                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2248                 }
2249             }
2250
2251             if (SvUOK(right)) {
2252                 /* ## UV <=> UV ## */
2253                 const UV leftuv = SvUVX(left);
2254                 const UV rightuv = SvUVX(right);
2255                 return (leftuv > rightuv) - (leftuv < rightuv);
2256             }
2257             /* ## UV <=> IV ## */
2258             {
2259                 const IV rightiv = SvIVX(right);
2260                 if (rightiv < 0)
2261                     /* As (a) is a UV, it's >=0, so it cannot be < */
2262                     return 1;
2263                 {
2264                     const UV leftuv = SvUVX(left);
2265                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2266                 }
2267             }
2268             NOT_REACHED; /* NOTREACHED */
2269     }
2270 #endif
2271     {
2272       NV const rnv = SvNV_nomg(right);
2273       NV const lnv = SvNV_nomg(left);
2274
2275 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2276       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2277           return 2;
2278        }
2279       return (lnv > rnv) - (lnv < rnv);
2280 #else
2281       if (lnv < rnv)
2282         return -1;
2283       if (lnv > rnv)
2284         return 1;
2285       if (lnv == rnv)
2286         return 0;
2287       return 2;
2288 #endif
2289     }
2290 }
2291
2292
2293 PP(pp_ncmp)
2294 {
2295     dSP;
2296     SV *left, *right;
2297     I32 value;
2298     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2299     right = POPs;
2300     left  = TOPs;
2301     value = do_ncmp(left, right);
2302     if (value == 2) {
2303         SETs(&PL_sv_undef);
2304     }
2305     else {
2306         dTARGET;
2307         SETi(value);
2308     }
2309     RETURN;
2310 }
2311
2312
2313 /* also used for: pp_sge() pp_sgt() pp_slt() */
2314
2315 PP(pp_sle)
2316 {
2317     dSP;
2318
2319     int amg_type = sle_amg;
2320     int multiplier = 1;
2321     int rhs = 1;
2322
2323     switch (PL_op->op_type) {
2324     case OP_SLT:
2325         amg_type = slt_amg;
2326         /* cmp < 0 */
2327         rhs = 0;
2328         break;
2329     case OP_SGT:
2330         amg_type = sgt_amg;
2331         /* cmp > 0 */
2332         multiplier = -1;
2333         rhs = 0;
2334         break;
2335     case OP_SGE:
2336         amg_type = sge_amg;
2337         /* cmp >= 0 */
2338         multiplier = -1;
2339         break;
2340     }
2341
2342     tryAMAGICbin_MG(amg_type, AMGf_set);
2343     {
2344       dPOPTOPssrl;
2345       const int cmp =
2346 #ifdef USE_LOCALE_COLLATE
2347                       (IN_LC_RUNTIME(LC_COLLATE))
2348                       ? sv_cmp_locale_flags(left, right, 0)
2349                       :
2350 #endif
2351                         sv_cmp_flags(left, right, 0);
2352       SETs(boolSV(cmp * multiplier < rhs));
2353       RETURN;
2354     }
2355 }
2356
2357 PP(pp_seq)
2358 {
2359     dSP;
2360     tryAMAGICbin_MG(seq_amg, AMGf_set);
2361     {
2362       dPOPTOPssrl;
2363       SETs(boolSV(sv_eq_flags(left, right, 0)));
2364       RETURN;
2365     }
2366 }
2367
2368 PP(pp_sne)
2369 {
2370     dSP;
2371     tryAMAGICbin_MG(sne_amg, AMGf_set);
2372     {
2373       dPOPTOPssrl;
2374       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2375       RETURN;
2376     }
2377 }
2378
2379 PP(pp_scmp)
2380 {
2381     dSP; dTARGET;
2382     tryAMAGICbin_MG(scmp_amg, 0);
2383     {
2384       dPOPTOPssrl;
2385       const int cmp =
2386 #ifdef USE_LOCALE_COLLATE
2387                       (IN_LC_RUNTIME(LC_COLLATE))
2388                       ? sv_cmp_locale_flags(left, right, 0)
2389                       :
2390 #endif
2391                         sv_cmp_flags(left, right, 0);
2392       SETi( cmp );
2393       RETURN;
2394     }
2395 }
2396
2397 PP(pp_bit_and)
2398 {
2399     dSP; dATARGET;
2400     tryAMAGICbin_MG(band_amg, AMGf_assign);
2401     {
2402       dPOPTOPssrl;
2403       if (SvNIOKp(left) || SvNIOKp(right)) {
2404         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2405         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2406         if (PL_op->op_private & HINT_INTEGER) {
2407           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2408           SETi(i);
2409         }
2410         else {
2411           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2412           SETu(u);
2413         }
2414         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2415         if (right_ro_nonnum) SvNIOK_off(right);
2416       }
2417       else {
2418         do_vop(PL_op->op_type, TARG, left, right);
2419         SETTARG;
2420       }
2421       RETURN;
2422     }
2423 }
2424
2425 PP(pp_nbit_and)
2426 {
2427     dSP;
2428     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2429     {
2430         dATARGET; dPOPTOPssrl;
2431         if (PL_op->op_private & HINT_INTEGER) {
2432           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2433           SETi(i);
2434         }
2435         else {
2436           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2437           SETu(u);
2438         }
2439     }
2440     RETURN;
2441 }
2442
2443 PP(pp_sbit_and)
2444 {
2445     dSP;
2446     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2447     {
2448         dATARGET; dPOPTOPssrl;
2449         do_vop(OP_BIT_AND, TARG, left, right);
2450         RETSETTARG;
2451     }
2452 }
2453
2454 /* also used for: pp_bit_xor() */
2455
2456 PP(pp_bit_or)
2457 {
2458     dSP; dATARGET;
2459     const int op_type = PL_op->op_type;
2460
2461     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2462     {
2463       dPOPTOPssrl;
2464       if (SvNIOKp(left) || SvNIOKp(right)) {
2465         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2466         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2467         if (PL_op->op_private & HINT_INTEGER) {
2468           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2469           const IV r = SvIV_nomg(right);
2470           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2471           SETi(result);
2472         }
2473         else {
2474           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2475           const UV r = SvUV_nomg(right);
2476           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2477           SETu(result);
2478         }
2479         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2480         if (right_ro_nonnum) SvNIOK_off(right);
2481       }
2482       else {
2483         do_vop(op_type, TARG, left, right);
2484         SETTARG;
2485       }
2486       RETURN;
2487     }
2488 }
2489
2490 /* also used for: pp_nbit_xor() */
2491
2492 PP(pp_nbit_or)
2493 {
2494     dSP;
2495     const int op_type = PL_op->op_type;
2496
2497     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2498                     AMGf_assign|AMGf_numarg);
2499     {
2500         dATARGET; dPOPTOPssrl;
2501         if (PL_op->op_private & HINT_INTEGER) {
2502           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2503           const IV r = SvIV_nomg(right);
2504           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2505           SETi(result);
2506         }
2507         else {
2508           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2509           const UV r = SvUV_nomg(right);
2510           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2511           SETu(result);
2512         }
2513     }
2514     RETURN;
2515 }
2516
2517 /* also used for: pp_sbit_xor() */
2518
2519 PP(pp_sbit_or)
2520 {
2521     dSP;
2522     const int op_type = PL_op->op_type;
2523
2524     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2525                     AMGf_assign);
2526     {
2527         dATARGET; dPOPTOPssrl;
2528         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2529                right);
2530         RETSETTARG;
2531     }
2532 }
2533
2534 PERL_STATIC_INLINE bool
2535 S_negate_string(pTHX)
2536 {
2537     dTARGET; dSP;
2538     STRLEN len;
2539     const char *s;
2540     SV * const sv = TOPs;
2541     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2542         return FALSE;
2543     s = SvPV_nomg_const(sv, len);
2544     if (isIDFIRST(*s)) {
2545         sv_setpvs(TARG, "-");
2546         sv_catsv(TARG, sv);
2547     }
2548     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2549         sv_setsv_nomg(TARG, sv);
2550         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2551     }
2552     else return FALSE;
2553     SETTARG;
2554     return TRUE;
2555 }
2556
2557 PP(pp_negate)
2558 {
2559     dSP; dTARGET;
2560     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2561     if (S_negate_string(aTHX)) return NORMAL;
2562     {
2563         SV * const sv = TOPs;
2564
2565         if (SvIOK(sv)) {
2566             /* It's publicly an integer */
2567         oops_its_an_int:
2568             if (SvIsUV(sv)) {
2569                 if (SvIVX(sv) == IV_MIN) {
2570                     /* 2s complement assumption. */
2571                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2572                                            IV_MIN */
2573                     return NORMAL;
2574                 }
2575                 else if (SvUVX(sv) <= IV_MAX) {
2576                     SETi(-SvIVX(sv));
2577                     return NORMAL;
2578                 }
2579             }
2580             else if (SvIVX(sv) != IV_MIN) {
2581                 SETi(-SvIVX(sv));
2582                 return NORMAL;
2583             }
2584 #ifdef PERL_PRESERVE_IVUV
2585             else {
2586                 SETu((UV)IV_MIN);
2587                 return NORMAL;
2588             }
2589 #endif
2590         }
2591         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2592             SETn(-SvNV_nomg(sv));
2593         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2594                   goto oops_its_an_int;
2595         else
2596             SETn(-SvNV_nomg(sv));
2597     }
2598     return NORMAL;
2599 }
2600
2601 PP(pp_not)
2602 {
2603     dSP;
2604     tryAMAGICun_MG(not_amg, AMGf_set);
2605     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2606     return NORMAL;
2607 }
2608
2609 static void
2610 S_scomplement(pTHX_ SV *targ, SV *sv)
2611 {
2612         U8 *tmps;
2613         I32 anum;
2614         STRLEN len;
2615
2616         sv_copypv_nomg(TARG, sv);
2617         tmps = (U8*)SvPV_nomg(TARG, len);
2618         anum = len;
2619         if (SvUTF8(TARG)) {
2620           /* Calculate exact length, let's not estimate. */
2621           STRLEN targlen = 0;
2622           STRLEN l;
2623           UV nchar = 0;
2624           UV nwide = 0;
2625           U8 * const send = tmps + len;
2626           U8 * const origtmps = tmps;
2627           const UV utf8flags = UTF8_ALLOW_ANYUV;
2628
2629           while (tmps < send) {
2630             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2631             tmps += l;
2632             targlen += UVCHR_SKIP(~c);
2633             nchar++;
2634             if (c > 0xff)
2635                 nwide++;
2636           }
2637
2638           /* Now rewind strings and write them. */
2639           tmps = origtmps;
2640
2641           if (nwide) {
2642               U8 *result;
2643               U8 *p;
2644
2645               Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2646                         deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]);
2647               Newx(result, targlen + 1, U8);
2648               p = result;
2649               while (tmps < send) {
2650                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2651                   tmps += l;
2652                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2653               }
2654               *p = '\0';
2655               sv_usepvn_flags(TARG, (char*)result, targlen,
2656                               SV_HAS_TRAILING_NUL);
2657               SvUTF8_on(TARG);
2658           }
2659           else {
2660               U8 *result;
2661               U8 *p;
2662
2663               Newx(result, nchar + 1, U8);
2664               p = result;
2665               while (tmps < send) {
2666                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2667                   tmps += l;
2668                   *p++ = ~c;
2669               }
2670               *p = '\0';
2671               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2672               SvUTF8_off(TARG);
2673           }
2674           return;
2675         }
2676 #ifdef LIBERAL
2677         {
2678             long *tmpl;
2679             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2680                 *tmps = ~*tmps;
2681             tmpl = (long*)tmps;
2682             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2683                 *tmpl = ~*tmpl;
2684             tmps = (U8*)tmpl;
2685         }
2686 #endif
2687         for ( ; anum > 0; anum--, tmps++)
2688             *tmps = ~*tmps;
2689 }
2690
2691 PP(pp_complement)
2692 {
2693     dSP; dTARGET;
2694     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2695     {
2696       dTOPss;
2697       if (SvNIOKp(sv)) {
2698         if (PL_op->op_private & HINT_INTEGER) {
2699           const IV i = ~SvIV_nomg(sv);
2700           SETi(i);
2701         }
2702         else {
2703           const UV u = ~SvUV_nomg(sv);
2704           SETu(u);
2705         }
2706       }
2707       else {
2708         S_scomplement(aTHX_ TARG, sv);
2709         SETTARG;
2710       }
2711       return NORMAL;
2712     }
2713 }
2714
2715 PP(pp_ncomplement)
2716 {
2717     dSP;
2718     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2719     {
2720         dTARGET; dTOPss;
2721         if (PL_op->op_private & HINT_INTEGER) {
2722           const IV i = ~SvIV_nomg(sv);
2723           SETi(i);
2724         }
2725         else {
2726           const UV u = ~SvUV_nomg(sv);
2727           SETu(u);
2728         }
2729     }
2730     return NORMAL;
2731 }
2732
2733 PP(pp_scomplement)
2734 {
2735     dSP;
2736     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2737     {
2738         dTARGET; dTOPss;
2739         S_scomplement(aTHX_ TARG, sv);
2740         SETTARG;
2741         return NORMAL;
2742     }
2743 }
2744
2745 /* integer versions of some of the above */
2746
2747 PP(pp_i_multiply)
2748 {
2749     dSP; dATARGET;
2750     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2751     {
2752       dPOPTOPiirl_nomg;
2753       SETi( left * right );
2754       RETURN;
2755     }
2756 }
2757
2758 PP(pp_i_divide)
2759 {
2760     IV num;
2761     dSP; dATARGET;
2762     tryAMAGICbin_MG(div_amg, AMGf_assign);
2763     {
2764       dPOPTOPssrl;
2765       IV value = SvIV_nomg(right);
2766       if (value == 0)
2767           DIE(aTHX_ "Illegal division by zero");
2768       num = SvIV_nomg(left);
2769
2770       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2771       if (value == -1)
2772           value = - num;
2773       else
2774           value = num / value;
2775       SETi(value);
2776       RETURN;
2777     }
2778 }
2779
2780 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2781     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2782 STATIC
2783 PP(pp_i_modulo_0)
2784 #else
2785 PP(pp_i_modulo)
2786 #endif
2787 {
2788      /* This is the vanilla old i_modulo. */
2789      dSP; dATARGET;
2790      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2791      {
2792           dPOPTOPiirl_nomg;
2793           if (!right)
2794                DIE(aTHX_ "Illegal modulus zero");
2795           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2796           if (right == -1)
2797               SETi( 0 );
2798           else
2799               SETi( left % right );
2800           RETURN;
2801      }
2802 }
2803
2804 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2805     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2806 STATIC
2807 PP(pp_i_modulo_1)
2808
2809 {
2810      /* This is the i_modulo with the workaround for the _moddi3 bug
2811       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2812       * See below for pp_i_modulo. */
2813      dSP; dATARGET;
2814      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2815      {
2816           dPOPTOPiirl_nomg;
2817           if (!right)
2818                DIE(aTHX_ "Illegal modulus zero");
2819           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2820           if (right == -1)
2821               SETi( 0 );
2822           else
2823               SETi( left % PERL_ABS(right) );
2824           RETURN;
2825      }
2826 }
2827
2828 PP(pp_i_modulo)
2829 {
2830      dVAR; dSP; dATARGET;
2831      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2832      {
2833           dPOPTOPiirl_nomg;
2834           if (!right)
2835                DIE(aTHX_ "Illegal modulus zero");
2836           /* The assumption is to use hereafter the old vanilla version... */
2837           PL_op->op_ppaddr =
2838                PL_ppaddr[OP_I_MODULO] =
2839                    Perl_pp_i_modulo_0;
2840           /* .. but if we have glibc, we might have a buggy _moddi3
2841            * (at least glibc 2.2.5 is known to have this bug), in other
2842            * words our integer modulus with negative quad as the second
2843            * argument might be broken.  Test for this and re-patch the
2844            * opcode dispatch table if that is the case, remembering to
2845            * also apply the workaround so that this first round works
2846            * right, too.  See [perl #9402] for more information. */
2847           {
2848                IV l =   3;
2849                IV r = -10;
2850                /* Cannot do this check with inlined IV constants since
2851                 * that seems to work correctly even with the buggy glibc. */
2852                if (l % r == -3) {
2853                     /* Yikes, we have the bug.
2854                      * Patch in the workaround version. */
2855                     PL_op->op_ppaddr =
2856                          PL_ppaddr[OP_I_MODULO] =
2857                              &Perl_pp_i_modulo_1;
2858                     /* Make certain we work right this time, too. */
2859                     right = PERL_ABS(right);
2860                }
2861           }
2862           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2863           if (right == -1)
2864               SETi( 0 );
2865           else
2866               SETi( left % right );
2867           RETURN;
2868      }
2869 }
2870 #endif
2871
2872 PP(pp_i_add)
2873 {
2874     dSP; dATARGET;
2875     tryAMAGICbin_MG(add_amg, AMGf_assign);
2876     {
2877       dPOPTOPiirl_ul_nomg;
2878       SETi( left + right );
2879       RETURN;
2880     }
2881 }
2882
2883 PP(pp_i_subtract)
2884 {
2885     dSP; dATARGET;
2886     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2887     {
2888       dPOPTOPiirl_ul_nomg;
2889       SETi( left - right );
2890       RETURN;
2891     }
2892 }
2893
2894 PP(pp_i_lt)
2895 {
2896     dSP;
2897     tryAMAGICbin_MG(lt_amg, AMGf_set);
2898     {
2899       dPOPTOPiirl_nomg;
2900       SETs(boolSV(left < right));
2901       RETURN;
2902     }
2903 }
2904
2905 PP(pp_i_gt)
2906 {
2907     dSP;
2908     tryAMAGICbin_MG(gt_amg, AMGf_set);
2909     {
2910       dPOPTOPiirl_nomg;
2911       SETs(boolSV(left > right));
2912       RETURN;
2913     }
2914 }
2915
2916 PP(pp_i_le)
2917 {
2918     dSP;
2919     tryAMAGICbin_MG(le_amg, AMGf_set);
2920     {
2921       dPOPTOPiirl_nomg;
2922       SETs(boolSV(left <= right));
2923       RETURN;
2924     }
2925 }
2926
2927 PP(pp_i_ge)
2928 {
2929     dSP;
2930     tryAMAGICbin_MG(ge_amg, AMGf_set);
2931     {
2932       dPOPTOPiirl_nomg;
2933       SETs(boolSV(left >= right));
2934       RETURN;
2935     }
2936 }
2937
2938 PP(pp_i_eq)
2939 {
2940     dSP;
2941     tryAMAGICbin_MG(eq_amg, AMGf_set);
2942     {
2943       dPOPTOPiirl_nomg;
2944       SETs(boolSV(left == right));
2945       RETURN;
2946     }
2947 }
2948
2949 PP(pp_i_ne)
2950 {
2951     dSP;
2952     tryAMAGICbin_MG(ne_amg, AMGf_set);
2953     {
2954       dPOPTOPiirl_nomg;
2955       SETs(boolSV(left != right));
2956       RETURN;
2957     }
2958 }
2959
2960 PP(pp_i_ncmp)
2961 {
2962     dSP; dTARGET;
2963     tryAMAGICbin_MG(ncmp_amg, 0);
2964     {
2965       dPOPTOPiirl_nomg;
2966       I32 value;
2967
2968       if (left > right)
2969         value = 1;
2970       else if (left < right)
2971         value = -1;
2972       else
2973         value = 0;
2974       SETi(value);
2975       RETURN;
2976     }
2977 }
2978
2979 PP(pp_i_negate)
2980 {
2981     dSP; dTARGET;
2982     tryAMAGICun_MG(neg_amg, 0);
2983     if (S_negate_string(aTHX)) return NORMAL;
2984     {
2985         SV * const sv = TOPs;
2986         IV const i = SvIV_nomg(sv);
2987         SETi(-i);
2988         return NORMAL;
2989     }
2990 }
2991
2992 /* High falutin' math. */
2993
2994 PP(pp_atan2)
2995 {
2996     dSP; dTARGET;
2997     tryAMAGICbin_MG(atan2_amg, 0);
2998     {
2999       dPOPTOPnnrl_nomg;
3000       SETn(Perl_atan2(left, right));
3001       RETURN;
3002     }
3003 }
3004
3005
3006 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
3007
3008 PP(pp_sin)
3009 {
3010     dSP; dTARGET;
3011     int amg_type = fallback_amg;
3012     const char *neg_report = NULL;
3013     const int op_type = PL_op->op_type;
3014
3015     switch (op_type) {
3016     case OP_SIN:  amg_type = sin_amg; break;
3017     case OP_COS:  amg_type = cos_amg; break;
3018     case OP_EXP:  amg_type = exp_amg; break;
3019     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
3020     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
3021     }
3022
3023     assert(amg_type != fallback_amg);
3024
3025     tryAMAGICun_MG(amg_type, 0);
3026     {
3027       SV * const arg = TOPs;
3028       const NV value = SvNV_nomg(arg);
3029       NV result = NV_NAN;
3030       if (neg_report) { /* log or sqrt */
3031           if (
3032 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3033               ! Perl_isnan(value) &&
3034 #endif
3035               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
3036               SET_NUMERIC_STANDARD();
3037               /* diag_listed_as: Can't take log of %g */
3038               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3039           }
3040       }
3041       switch (op_type) {
3042       default:
3043       case OP_SIN:  result = Perl_sin(value);  break;
3044       case OP_COS:  result = Perl_cos(value);  break;
3045       case OP_EXP:  result = Perl_exp(value);  break;
3046       case OP_LOG:  result = Perl_log(value);  break;
3047       case OP_SQRT: result = Perl_sqrt(value); break;
3048       }
3049       SETn(result);
3050       return NORMAL;
3051     }
3052 }
3053
3054 /* Support Configure command-line overrides for rand() functions.
3055    After 5.005, perhaps we should replace this by Configure support
3056    for drand48(), random(), or rand().  For 5.005, though, maintain
3057    compatibility by calling rand() but allow the user to override it.
3058    See INSTALL for details.  --Andy Dougherty  15 July 1998
3059 */
3060 /* Now it's after 5.005, and Configure supports drand48() and random(),
3061    in addition to rand().  So the overrides should not be needed any more.
3062    --Jarkko Hietaniemi  27 September 1998
3063  */
3064
3065 PP(pp_rand)
3066 {
3067     if (!PL_srand_called) {
3068         (void)seedDrand01((Rand_seed_t)seed());
3069         PL_srand_called = TRUE;
3070     }
3071     {
3072         dSP;
3073         NV value;
3074
3075         if (MAXARG < 1)
3076         {
3077             EXTEND(SP, 1);
3078             value = 1.0;
3079         }
3080         else {
3081             SV * const sv = POPs;
3082             if(!sv)
3083                 value = 1.0;
3084             else
3085                 value = SvNV(sv);
3086         }
3087     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3088 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3089         if (! Perl_isnan(value) && value == 0.0)
3090 #else
3091         if (value == 0.0)
3092 #endif
3093             value = 1.0;
3094         {
3095             dTARGET;
3096             PUSHs(TARG);
3097             PUTBACK;
3098             value *= Drand01();
3099             sv_setnv_mg(TARG, value);
3100         }
3101     }
3102     return NORMAL;
3103 }
3104
3105 PP(pp_srand)
3106 {
3107     dSP; dTARGET;
3108     UV anum;
3109
3110     if (MAXARG >= 1 && (TOPs || POPs)) {
3111         SV *top;
3112         char *pv;
3113         STRLEN len;
3114         int flags;
3115
3116         top = POPs;
3117         pv = SvPV(top, len);
3118         flags = grok_number(pv, len, &anum);
3119
3120         if (!(flags & IS_NUMBER_IN_UV)) {
3121             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3122                              "Integer overflow in srand");
3123             anum = UV_MAX;
3124         }
3125     }
3126     else {
3127         anum = seed();
3128     }
3129
3130     (void)seedDrand01((Rand_seed_t)anum);
3131     PL_srand_called = TRUE;
3132     if (anum)
3133         XPUSHu(anum);
3134     else {
3135         /* Historically srand always returned true. We can avoid breaking
3136            that like this:  */
3137         sv_setpvs(TARG, "0 but true");
3138         XPUSHTARG;
3139     }
3140     RETURN;
3141 }
3142
3143 PP(pp_int)
3144 {
3145     dSP; dTARGET;
3146     tryAMAGICun_MG(int_amg, AMGf_numeric);
3147     {
3148       SV * const sv = TOPs;
3149       const IV iv = SvIV_nomg(sv);
3150       /* XXX it's arguable that compiler casting to IV might be subtly
3151          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3152          else preferring IV has introduced a subtle behaviour change bug. OTOH
3153          relying on floating point to be accurate is a bug.  */
3154
3155       if (!SvOK(sv)) {
3156         SETu(0);
3157       }
3158       else if (SvIOK(sv)) {
3159         if (SvIsUV(sv))
3160             SETu(SvUV_nomg(sv));
3161         else
3162             SETi(iv);
3163       }
3164       else {
3165           const NV value = SvNV_nomg(sv);
3166           if (UNLIKELY(Perl_isinfnan(value)))
3167               SETn(value);
3168           else if (value >= 0.0) {
3169               if (value < (NV)UV_MAX + 0.5) {
3170                   SETu(U_V(value));
3171               } else {
3172                   SETn(Perl_floor(value));
3173               }
3174           }
3175           else {
3176               if (value > (NV)IV_MIN - 0.5) {
3177                   SETi(I_V(value));
3178               } else {
3179                   SETn(Perl_ceil(value));
3180               }
3181           }
3182       }
3183     }
3184     return NORMAL;
3185 }
3186
3187 PP(pp_abs)
3188 {
3189     dSP; dTARGET;
3190     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3191     {
3192       SV * const sv = TOPs;
3193       /* This will cache the NV value if string isn't actually integer  */
3194       const IV iv = SvIV_nomg(sv);
3195
3196       if (!SvOK(sv)) {
3197         SETu(0);
3198       }
3199       else if (SvIOK(sv)) {
3200         /* IVX is precise  */
3201         if (SvIsUV(sv)) {
3202           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3203         } else {
3204           if (iv >= 0) {
3205             SETi(iv);
3206           } else {
3207             if (iv != IV_MIN) {
3208               SETi(-iv);
3209             } else {
3210               /* 2s complement assumption. Also, not really needed as
3211                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3212               SETu(IV_MIN);
3213             }
3214           }
3215         }
3216       } else{
3217         const NV value = SvNV_nomg(sv);
3218         if (value < 0.0)
3219           SETn(-value);
3220         else
3221           SETn(value);
3222       }
3223     }
3224     return NORMAL;
3225 }
3226
3227
3228 /* also used for: pp_hex() */
3229
3230 PP(pp_oct)
3231 {
3232     dSP; dTARGET;
3233     const char *tmps;
3234     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3235     STRLEN len;
3236     NV result_nv;
3237     UV result_uv;
3238     SV* const sv = TOPs;
3239
3240     tmps = (SvPV_const(sv, len));
3241     if (DO_UTF8(sv)) {
3242          /* If Unicode, try to downgrade
3243           * If not possible, croak. */
3244          SV* const tsv = sv_2mortal(newSVsv(sv));
3245
3246          SvUTF8_on(tsv);
3247          sv_utf8_downgrade(tsv, FALSE);
3248          tmps = SvPV_const(tsv, len);
3249     }
3250     if (PL_op->op_type == OP_HEX)
3251         goto hex;
3252
3253     while (*tmps && len && isSPACE(*tmps))
3254         tmps++, len--;
3255     if (*tmps == '0')
3256         tmps++, len--;
3257     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3258     hex:
3259         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3260     }
3261     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3262         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3263     else
3264         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3265
3266     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3267         SETn(result_nv);
3268     }
3269     else {
3270         SETu(result_uv);
3271     }
3272     return NORMAL;
3273 }
3274
3275 /* String stuff. */
3276
3277 PP(pp_length)
3278 {
3279     dSP; dTARGET;
3280     SV * const sv = TOPs;
3281
3282     U32 in_bytes = IN_BYTES;
3283     /* simplest case shortcut */
3284     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3285     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3286     STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3287     SETs(TARG);
3288
3289     if(LIKELY(svflags == SVf_POK))
3290         goto simple_pv;
3291     if(svflags & SVs_GMG)
3292         mg_get(sv);
3293     if (SvOK(sv)) {
3294         if (!IN_BYTES) /* reread to avoid using an C auto/register */
3295             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3296         else
3297         {
3298             STRLEN len;
3299             /* unrolled SvPV_nomg_const(sv,len) */
3300             if(SvPOK_nog(sv)){
3301                 simple_pv:
3302                 len = SvCUR(sv);
3303             } else  {
3304                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3305             }
3306             sv_setiv(TARG, (IV)(len));
3307         }
3308     } else {
3309         if (!SvPADTMP(TARG)) {
3310             sv_setsv_nomg(TARG, &PL_sv_undef);
3311         } else { /* TARG is on stack at this point and is overwriten by SETs.
3312                    This branch is the odd one out, so put TARG by default on
3313                    stack earlier to let local SP go out of liveness sooner */
3314             SETs(&PL_sv_undef);
3315             goto no_set_magic;
3316         }
3317     }
3318     SvSETMAGIC(TARG);
3319     no_set_magic:
3320     return NORMAL; /* no putback, SP didn't move in this opcode */
3321 }
3322
3323 /* Returns false if substring is completely outside original string.
3324    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3325    always be true for an explicit 0.
3326 */
3327 bool
3328 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3329                                 bool pos1_is_uv, IV len_iv,
3330                                 bool len_is_uv, STRLEN *posp,
3331                                 STRLEN *lenp)
3332 {
3333     IV pos2_iv;
3334     int    pos2_is_uv;
3335
3336     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3337
3338     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3339         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3340         pos1_iv += curlen;
3341     }
3342     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3343         return FALSE;
3344
3345     if (len_iv || len_is_uv) {
3346         if (!len_is_uv && len_iv < 0) {
3347             pos2_iv = curlen + len_iv;
3348             if (curlen)
3349                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3350             else
3351                 pos2_is_uv = 0;
3352         } else {  /* len_iv >= 0 */
3353             if (!pos1_is_uv && pos1_iv < 0) {
3354                 pos2_iv = pos1_iv + len_iv;
3355                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3356             } else {
3357                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3358                     pos2_iv = curlen;
3359                 else
3360                     pos2_iv = pos1_iv+len_iv;
3361                 pos2_is_uv = 1;
3362             }
3363         }
3364     }
3365     else {
3366         pos2_iv = curlen;
3367         pos2_is_uv = 1;
3368     }
3369
3370     if (!pos2_is_uv && pos2_iv < 0) {
3371         if (!pos1_is_uv && pos1_iv < 0)
3372             return FALSE;
3373         pos2_iv = 0;
3374     }
3375     else if (!pos1_is_uv && pos1_iv < 0)
3376         pos1_iv = 0;
3377
3378     if ((UV)pos2_iv < (UV)pos1_iv)
3379         pos2_iv = pos1_iv;
3380     if ((UV)pos2_iv > curlen)
3381         pos2_iv = curlen;
3382
3383     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3384     *posp = (STRLEN)( (UV)pos1_iv );
3385     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3386
3387     return TRUE;
3388 }
3389
3390 PP(pp_substr)
3391 {
3392     dSP; dTARGET;
3393     SV *sv;
3394     STRLEN curlen;
3395     STRLEN utf8_curlen;
3396     SV *   pos_sv;
3397     IV     pos1_iv;
3398     int    pos1_is_uv;
3399     SV *   len_sv;
3400     IV     len_iv = 0;
3401     int    len_is_uv = 0;
3402     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3403     const bool rvalue = (GIMME_V != G_VOID);
3404     const char *tmps;
3405     SV *repl_sv = NULL;
3406     const char *repl = NULL;
3407     STRLEN repl_len;
3408     int num_args = PL_op->op_private & 7;
3409     bool repl_need_utf8_upgrade = FALSE;
3410
3411     if (num_args > 2) {
3412         if (num_args > 3) {
3413           if(!(repl_sv = POPs)) num_args--;
3414         }
3415         if ((len_sv = POPs)) {
3416             len_iv    = SvIV(len_sv);
3417             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3418         }
3419         else num_args--;
3420     }
3421     pos_sv     = POPs;
3422     pos1_iv    = SvIV(pos_sv);
3423     pos1_is_uv = SvIOK_UV(pos_sv);
3424     sv = POPs;
3425     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3426         assert(!repl_sv);
3427         repl_sv = POPs;
3428     }
3429     if (lvalue && !repl_sv) {
3430         SV * ret;
3431         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3432         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3433         LvTYPE(ret) = 'x';
3434         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3435         LvTARGOFF(ret) =
3436             pos1_is_uv || pos1_iv >= 0
3437                 ? (STRLEN)(UV)pos1_iv
3438                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3439         LvTARGLEN(ret) =
3440             len_is_uv || len_iv > 0
3441                 ? (STRLEN)(UV)len_iv
3442                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3443
3444         PUSHs(ret);    /* avoid SvSETMAGIC here */
3445         RETURN;
3446     }
3447     if (repl_sv) {
3448         repl = SvPV_const(repl_sv, repl_len);
3449         SvGETMAGIC(sv);
3450         if (SvROK(sv))
3451             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3452                             "Attempt to use reference as lvalue in substr"
3453             );
3454         tmps = SvPV_force_nomg(sv, curlen);
3455         if (DO_UTF8(repl_sv) && repl_len) {
3456             if (!DO_UTF8(sv)) {
3457                 sv_utf8_upgrade_nomg(sv);
3458                 curlen = SvCUR(sv);
3459             }
3460         }
3461         else if (DO_UTF8(sv))
3462             repl_need_utf8_upgrade = TRUE;
3463     }
3464     else tmps = SvPV_const(sv, curlen);
3465     if (DO_UTF8(sv)) {
3466         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3467         if (utf8_curlen == curlen)
3468             utf8_curlen = 0;
3469         else
3470             curlen = utf8_curlen;
3471     }
3472     else
3473         utf8_curlen = 0;
3474
3475     {
3476         STRLEN pos, len, byte_len, byte_pos;
3477
3478         if (!translate_substr_offsets(
3479                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3480         )) goto bound_fail;
3481
3482         byte_len = len;
3483         byte_pos = utf8_curlen
3484             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3485
3486         tmps += byte_pos;
3487
3488         if (rvalue) {
3489             SvTAINTED_off(TARG);                        /* decontaminate */
3490             SvUTF8_off(TARG);                   /* decontaminate */
3491             sv_setpvn(TARG, tmps, byte_len);
3492 #ifdef USE_LOCALE_COLLATE
3493             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3494 #endif
3495             if (utf8_curlen)
3496                 SvUTF8_on(TARG);
3497         }
3498
3499         if (repl) {
3500             SV* repl_sv_copy = NULL;
3501
3502             if (repl_need_utf8_upgrade) {
3503                 repl_sv_copy = newSVsv(repl_sv);
3504                 sv_utf8_upgrade(repl_sv_copy);
3505                 repl = SvPV_const(repl_sv_copy, repl_len);
3506             }
3507             if (!SvOK(sv))
3508                 sv_setpvs(sv, "");
3509             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3510             SvREFCNT_dec(repl_sv_copy);
3511         }
3512     }
3513     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3514         SP++;
3515     else if (rvalue) {
3516         SvSETMAGIC(TARG);
3517         PUSHs(TARG);
3518     }
3519     RETURN;
3520
3521   bound_fail:
3522     if (repl)
3523         Perl_croak(aTHX_ "substr outside of string");
3524     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3525     RETPUSHUNDEF;
3526 }
3527
3528 PP(pp_vec)
3529 {
3530     dSP;
3531     const IV size   = POPi;
3532     const IV offset = POPi;
3533     SV * const src = POPs;
3534     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3535     SV * ret;
3536
3537     if (lvalue) {                       /* it's an lvalue! */
3538         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3539         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3540         LvTYPE(ret) = 'v';
3541         LvTARG(ret) = SvREFCNT_inc_simple(src);
3542         LvTARGOFF(ret) = offset;
3543         LvTARGLEN(ret) = size;
3544     }
3545     else {
3546         dTARGET;
3547         SvTAINTED_off(TARG);            /* decontaminate */
3548         ret = TARG;
3549     }
3550
3551     sv_setuv(ret, do_vecget(src, offset, size));
3552     if (!lvalue)
3553         SvSETMAGIC(ret);
3554     PUSHs(ret);
3555     RETURN;
3556 }
3557
3558
3559 /* also used for: pp_rindex() */
3560
3561 PP(pp_index)
3562 {
3563     dSP; dTARGET;
3564     SV *big;
3565     SV *little;
3566     SV *temp = NULL;
3567     STRLEN biglen;
3568     STRLEN llen = 0;
3569     SSize_t offset = 0;
3570     SSize_t retval;
3571     const char *big_p;
3572     const char *little_p;
3573     bool big_utf8;
3574     bool little_utf8;
3575     const bool is_index = PL_op->op_type == OP_INDEX;
3576     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3577
3578     if (threeargs)
3579         offset = POPi;
3580     little = POPs;
3581     big = POPs;
3582     big_p = SvPV_const(big, biglen);
3583     little_p = SvPV_const(little, llen);
3584
3585     big_utf8 = DO_UTF8(big);
3586     little_utf8 = DO_UTF8(little);
3587     if (big_utf8 ^ little_utf8) {
3588         /* One needs to be upgraded.  */
3589         if (little_utf8 && !IN_ENCODING) {
3590             /* Well, maybe instead we might be able to downgrade the small
3591                string?  */
3592             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3593                                                      &little_utf8);
3594             if (little_utf8) {
3595                 /* If the large string is ISO-8859-1, and it's not possible to
3596                    convert the small string to ISO-8859-1, then there is no
3597                    way that it could be found anywhere by index.  */
3598                 retval = -1;
3599                 goto fail;
3600             }
3601
3602             /* At this point, pv is a malloc()ed string. So donate it to temp
3603                to ensure it will get free()d  */
3604             little = temp = newSV(0);
3605             sv_usepvn(temp, pv, llen);
3606             little_p = SvPVX(little);
3607         } else {
3608             temp = little_utf8
3609                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3610
3611             if (IN_ENCODING) {
3612                 sv_recode_to_utf8(temp, _get_encoding());
3613             } else {
3614                 sv_utf8_upgrade(temp);
3615             }
3616             if (little_utf8) {
3617                 big = temp;
3618                 big_utf8 = TRUE;
3619                 big_p = SvPV_const(big, biglen);
3620             } else {
3621                 little = temp;
3622                 little_p = SvPV_const(little, llen);
3623             }
3624         }
3625     }
3626     if (SvGAMAGIC(big)) {
3627         /* Life just becomes a lot easier if I use a temporary here.
3628            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3629            will trigger magic and overloading again, as will fbm_instr()
3630         */
3631         big = newSVpvn_flags(big_p, biglen,
3632                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3633         big_p = SvPVX(big);
3634     }
3635     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3636         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3637            warn on undef, and we've already triggered a warning with the
3638            SvPV_const some lines above. We can't remove that, as we need to
3639            call some SvPV to trigger overloading early and find out if the
3640            string is UTF-8.
3641            This is all getting too messy. The API isn't quite clean enough,
3642            because data access has side effects.
3643         */
3644         little = newSVpvn_flags(little_p, llen,
3645                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3646         little_p = SvPVX(little);
3647     }
3648
3649     if (!threeargs)
3650         offset = is_index ? 0 : biglen;
3651     else {
3652         if (big_utf8 && offset > 0)
3653             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3654         if (!is_index)
3655             offset += llen;
3656     }
3657     if (offset < 0)
3658         offset = 0;
3659     else if (offset > (SSize_t)biglen)
3660         offset = biglen;
3661     if (!(little_p = is_index
3662           ? fbm_instr((unsigned char*)big_p + offset,
3663                       (unsigned char*)big_p + biglen, little, 0)
3664           : rninstr(big_p,  big_p  + offset,
3665                     little_p, little_p + llen)))
3666         retval = -1;
3667     else {
3668         retval = little_p - big_p;
3669         if (retval > 1 && big_utf8)
3670             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3671     }
3672     SvREFCNT_dec(temp);
3673  fail:
3674     PUSHi(retval);
3675     RETURN;
3676 }
3677
3678 PP(pp_sprintf)
3679 {
3680     dSP; dMARK; dORIGMARK; dTARGET;
3681     SvTAINTED_off(TARG);
3682     do_sprintf(TARG, SP-MARK, MARK+1);
3683     TAINT_IF(SvTAINTED(TARG));
3684     SP = ORIGMARK;
3685     PUSHTARG;
3686     RETURN;
3687 }
3688
3689 PP(pp_ord)
3690 {
3691     dSP; dTARGET;
3692
3693     SV *argsv = TOPs;
3694     STRLEN len;
3695     const U8 *s = (U8*)SvPV_const(argsv, len);
3696
3697     if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3698         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3699         s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3700         len = UTF8SKIP(s);  /* Should be well-formed; so this is its length */
3701         argsv = tmpsv;
3702     }
3703
3704     SETu(DO_UTF8(argsv)
3705            ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3706            : (UV)(*s));
3707
3708     return NORMAL;
3709 }
3710
3711 PP(pp_chr)
3712 {
3713     dSP; dTARGET;
3714     char *tmps;
3715     UV value;
3716     SV *top = TOPs;
3717
3718     SvGETMAGIC(top);
3719     if (UNLIKELY(SvAMAGIC(top)))
3720         top = sv_2num(top);
3721     if (UNLIKELY(isinfnansv(top)))
3722         Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3723     else {
3724         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3725             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3726                 ||
3727                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3728                  && SvNV_nomg(top) < 0.0)))
3729         {
3730             if (ckWARN(WARN_UTF8)) {
3731                 if (SvGMAGICAL(top)) {
3732                     SV *top2 = sv_newmortal();
3733                     sv_setsv_nomg(top2, top);
3734                     top = top2;
3735                 }
3736                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3737                             "Invalid negative number (%"SVf") in chr", SVfARG(top));
3738             }
3739             value = UNICODE_REPLACEMENT;
3740         } else {
3741             value = SvUV_nomg(top);
3742         }
3743     }
3744
3745     SvUPGRADE(TARG,SVt_PV);
3746
3747     if (value > 255 && !IN_BYTES) {
3748         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3749         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3750         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3751         *tmps = '\0';
3752         (void)SvPOK_only(TARG);
3753         SvUTF8_on(TARG);
3754         SETTARG;
3755         return NORMAL;
3756     }
3757
3758     SvGROW(TARG,2);
3759     SvCUR_set(TARG, 1);
3760     tmps = SvPVX(TARG);
3761     *tmps++ = (char)value;
3762     *tmps = '\0';
3763     (void)SvPOK_only(TARG);
3764
3765     if (IN_ENCODING && !IN_BYTES) {
3766         sv_recode_to_utf8(TARG, _get_encoding());
3767         tmps = SvPVX(TARG);
3768         if (SvCUR(TARG) == 0
3769             || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3770             || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3771         {
3772             SvGROW(TARG, 2);
3773             tmps = SvPVX(TARG);
3774             SvCUR_set(TARG, 1);
3775             *tmps++ = (char)value;
3776             *tmps = '\0';
3777             SvUTF8_off(TARG);
3778         }
3779     }
3780
3781     SETTARG;
3782     return NORMAL;
3783 }
3784
3785 PP(pp_crypt)
3786 {
3787 #ifdef HAS_CRYPT
3788     dSP; dTARGET;
3789     dPOPTOPssrl;
3790     STRLEN len;
3791     const char *tmps = SvPV_const(left, len);
3792
3793     if (DO_UTF8(left)) {
3794          /* If Unicode, try to downgrade.
3795           * If not possible, croak.
3796           * Yes, we made this up.  */
3797          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3798
3799          sv_utf8_downgrade(tsv, FALSE);
3800          tmps = SvPV_const(tsv, len);
3801     }
3802 #   ifdef USE_ITHREADS
3803 #     ifdef HAS_CRYPT_R
3804     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3805       /* This should be threadsafe because in ithreads there is only
3806        * one thread per interpreter.  If this would not be true,
3807        * we would need a mutex to protect this malloc. */
3808         PL_reentrant_buffer->_crypt_struct_buffer =
3809           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3810 #if defined(__GLIBC__) || defined(__EMX__)
3811         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3812             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3813             /* work around glibc-2.2.5 bug */
3814             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3815         }
3816 #endif
3817     }
3818 #     endif /* HAS_CRYPT_R */
3819 #   endif /* USE_ITHREADS */
3820 #   ifdef FCRYPT
3821     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3822 #   else
3823     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3824 #   endif
3825     SvUTF8_off(TARG);
3826     SETTARG;
3827     RETURN;
3828 #else
3829     DIE(aTHX_
3830       "The crypt() function is unimplemented due to excessive paranoia.");
3831 #endif
3832 }
3833
3834 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3835  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3836
3837
3838 /* also used for: pp_lcfirst() */
3839
3840 PP(pp_ucfirst)
3841 {
3842     /* Actually is both lcfirst() and ucfirst().  Only the first character
3843      * changes.  This means that possibly we can change in-place, ie., just
3844      * take the source and change that one character and store it back, but not
3845      * if read-only etc, or if the length changes */
3846
3847     dSP;
3848     SV *source = TOPs;
3849     STRLEN slen; /* slen is the byte length of the whole SV. */
3850     STRLEN need;
3851     SV *dest;
3852     bool inplace;   /* ? Convert first char only, in-place */
3853     bool doing_utf8 = FALSE;               /* ? using utf8 */
3854     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3855     const int op_type = PL_op->op_type;
3856     const U8 *s;
3857     U8 *d;
3858     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3859     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3860                      * stored as UTF-8 at s. */
3861     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3862                      * lowercased) character stored in tmpbuf.  May be either
3863                      * UTF-8 or not, but in either case is the number of bytes */
3864
3865     s = (const U8*)SvPV_const(source, slen);
3866
3867     /* We may be able to get away with changing only the first character, in
3868      * place, but not if read-only, etc.  Later we may discover more reasons to
3869      * not convert in-place. */
3870     inplace = !SvREADONLY(source)
3871            && (  SvPADTMP(source)
3872               || (  SvTEMP(source) && !SvSMAGICAL(source)
3873                  && SvREFCNT(source) == 1));
3874
3875     /* First calculate what the changed first character should be.  This affects
3876      * whether we can just swap it out, leaving the rest of the string unchanged,
3877      * or even if have to convert the dest to UTF-8 when the source isn't */
3878
3879     if (! slen) {   /* If empty */
3880         need = 1; /* still need a trailing NUL */
3881         ulen = 0;
3882     }
3883     else if (DO_UTF8(source)) { /* Is the source utf8? */
3884         doing_utf8 = TRUE;
3885         ulen = UTF8SKIP(s);
3886         if (op_type == OP_UCFIRST) {
3887 #ifdef USE_LOCALE_CTYPE
3888             _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3889 #else
3890             _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3891 #endif
3892         }
3893         else {
3894 #ifdef USE_LOCALE_CTYPE
3895             _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3896 #else
3897             _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3898 #endif
3899         }
3900
3901         /* we can't do in-place if the length changes.  */
3902         if (ulen != tculen) inplace = FALSE;
3903         need = slen + 1 - ulen + tculen;
3904     }
3905     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3906             * latin1 is treated as caseless.  Note that a locale takes
3907             * precedence */
3908         ulen = 1;       /* Original character is 1 byte */
3909         tculen = 1;     /* Most characters will require one byte, but this will
3910                          * need to be overridden for the tricky ones */
3911         need = slen + 1;
3912
3913         if (op_type == OP_LCFIRST) {
3914
3915             /* lower case the first letter: no trickiness for any character */
3916 #ifdef USE_LOCALE_CTYPE
3917             if (IN_LC_RUNTIME(LC_CTYPE)) {
3918                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3919                 *tmpbuf = toLOWER_LC(*s);
3920             }
3921             else
3922 #endif
3923             {
3924                 *tmpbuf = (IN_UNI_8_BIT)
3925                           ? toLOWER_LATIN1(*s)
3926                           : toLOWER(*s);
3927             }
3928         }
3929 #ifdef USE_LOCALE_CTYPE
3930         /* is ucfirst() */
3931         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3932             if (IN_UTF8_CTYPE_LOCALE) {
3933                 goto do_uni_rules;
3934             }
3935
3936             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3937             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3938                                               locales have upper and title case
3939                                               different */
3940         }
3941 #endif
3942         else if (! IN_UNI_8_BIT) {
3943             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3944                                          * on EBCDIC machines whatever the
3945                                          * native function does */
3946         }
3947         else {
3948             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3949              * UTF-8, which we treat as not in locale), and cased latin1 */
3950             UV title_ord;
3951 #ifdef USE_LOCALE_CTYPE
3952       do_uni_rules:
3953 #endif
3954
3955             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3956             if (tculen > 1) {
3957                 assert(tculen == 2);
3958
3959                 /* If the result is an upper Latin1-range character, it can
3960                  * still be represented in one byte, which is its ordinal */
3961                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3962                     *tmpbuf = (U8) title_ord;
3963                     tculen = 1;
3964                 }
3965                 else {
3966                     /* Otherwise it became more than one ASCII character (in
3967                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3968                      * beyond Latin1, so the number of bytes changed, so can't
3969                      * replace just the first character in place. */
3970                     inplace = FALSE;
3971
3972                     /* If the result won't fit in a byte, the entire result
3973                      * will have to be in UTF-8.  Assume worst case sizing in
3974                      * conversion. (all latin1 characters occupy at most two
3975                      * bytes in utf8) */
3976                     if (title_ord > 255) {
3977                         doing_utf8 = TRUE;
3978                         convert_source_to_utf8 = TRUE;
3979                         need = slen * 2 + 1;
3980
3981                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3982                          * (both) characters whose title case is above 255 is
3983                          * 2. */
3984                         ulen = 2;
3985                     }
3986                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3987                         need = slen + 1 + 1;
3988                     }
3989                 }
3990             }
3991         } /* End of use Unicode (Latin1) semantics */
3992     } /* End of changing the case of the first character */
3993
3994     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3995      * generate the result */
3996     if (inplace) {
3997
3998         /* We can convert in place.  This means we change just the first
3999          * character without disturbing the rest; no need to grow */
4000         dest = source;
4001         s = d = (U8*)SvPV_force_nomg(source, slen);
4002     } else {
4003         dTARGET;
4004
4005         dest = TARG;
4006
4007         /* Here, we can't convert in place; we earlier calculated how much
4008          * space we will need, so grow to accommodate that */
4009         SvUPGRADE(dest, SVt_PV);
4010         d = (U8*)SvGROW(dest, need);
4011         (void)SvPOK_only(dest);
4012
4013         SETs(dest);
4014     }
4015
4016     if (doing_utf8) {
4017         if (! inplace) {
4018             if (! convert_source_to_utf8) {
4019
4020                 /* Here  both source and dest are in UTF-8, but have to create
4021                  * the entire output.  We initialize the result to be the
4022                  * title/lower cased first character, and then append the rest
4023                  * of the string. */
4024                 sv_setpvn(dest, (char*)tmpbuf, tculen);
4025                 if (slen > ulen) {
4026                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
4027                 }
4028             }
4029             else {
4030                 const U8 *const send = s + slen;
4031
4032                 /* Here the dest needs to be in UTF-8, but the source isn't,
4033                  * except we earlier UTF-8'd the first character of the source
4034                  * into tmpbuf.  First put that into dest, and then append the
4035                  * rest of the source, converting it to UTF-8 as we go. */
4036
4037                 /* Assert tculen is 2 here because the only two characters that
4038                  * get to this part of the code have 2-byte UTF-8 equivalents */
4039                 *d++ = *tmpbuf;
4040                 *d++ = *(tmpbuf + 1);
4041                 s++;    /* We have just processed the 1st char */
4042
4043                 for (; s < send; s++) {
4044                     d = uvchr_to_utf8(d, *s);
4045                 }
4046                 *d = '\0';
4047                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4048             }
4049             SvUTF8_on(dest);
4050         }
4051         else {   /* in-place UTF-8.  Just overwrite the first character */
4052             Copy(tmpbuf, d, tculen, U8);
4053             SvCUR_set(dest, need - 1);
4054         }
4055
4056     }
4057     else {  /* Neither source nor dest are in or need to be UTF-8 */
4058         if (slen) {
4059             if (inplace) {  /* in-place, only need to change the 1st char */
4060                 *d = *tmpbuf;
4061             }
4062             else {      /* Not in-place */
4063
4064                 /* Copy the case-changed character(s) from tmpbuf */
4065                 Copy(tmpbuf, d, tculen, U8);
4066                 d += tculen - 1; /* Code below expects d to point to final
4067                                   * character stored */
4068             }
4069         }
4070         else {  /* empty source */
4071             /* See bug #39028: Don't taint if empty  */
4072             *d = *s;
4073         }
4074
4075         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4076          * the destination to retain that flag */
4077         if (SvUTF8(source) && ! IN_BYTES)
4078             SvUTF8_on(dest);
4079
4080         if (!inplace) { /* Finish the rest of the string, unchanged */
4081             /* This will copy the trailing NUL  */
4082             Copy(s + 1, d + 1, slen, U8);
4083             SvCUR_set(dest, need - 1);
4084         }
4085     }
4086 #ifdef USE_LOCALE_CTYPE
4087     if (IN_LC_RUNTIME(LC_CTYPE)) {
4088         TAINT;
4089         SvTAINTED_on(dest);
4090     }
4091 #endif
4092     if (dest != source && SvTAINTED(source))
4093         SvTAINT(dest);
4094     SvSETMAGIC(dest);
4095     return NORMAL;
4096 }
4097
4098 /* There's so much setup/teardown code common between uc and lc, I wonder if
4099    it would be worth merging the two, and just having a switch outside each
4100    of the three tight loops.  There is less and less commonality though */
4101 PP(pp_uc)
4102 {
4103     dSP;
4104     SV *source = TOPs;
4105     STRLEN len;
4106     STRLEN min;
4107     SV *dest;
4108     const U8 *s;
4109     U8 *d;
4110
4111     SvGETMAGIC(source);
4112
4113     if ((SvPADTMP(source)
4114          ||
4115         (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
4116         && !SvREADONLY(source) && SvPOK(source)
4117         && !DO_UTF8(source)
4118         && (
4119 #ifdef USE_LOCALE_CTYPE
4120             (IN_LC_RUNTIME(LC_CTYPE))
4121             ? ! IN_UTF8_CTYPE_LOCALE
4122             :
4123 #endif
4124               ! IN_UNI_8_BIT))
4125     {
4126
4127         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4128          * make the loop tight, so we overwrite the source with the dest before
4129          * looking at it, and we need to look at the original source
4130          * afterwards.  There would also need to be code added to handle
4131          * switching to not in-place in midstream if we run into characters
4132          * that change the length.  Since being in locale overrides UNI_8_BIT,
4133          * that latter becomes irrelevant in the above test; instead for
4134          * locale, the size can't normally change, except if the locale is a
4135          * UTF-8 one */
4136         dest = source;
4137         s = d = (U8*)SvPV_force_nomg(source, len);
4138         min = len + 1;
4139     } else {
4140         dTARGET;
4141
4142         dest = TARG;
4143
4144         s = (const U8*)SvPV_nomg_const(source, len);
4145         min = len + 1;
4146
4147         SvUPGRADE(dest, SVt_PV);
4148         d = (U8*)SvGROW(dest, min);
4149         (void)SvPOK_only(dest);
4150
4151         SETs(dest);
4152     }
4153
4154     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4155        to check DO_UTF8 again here.  */
4156
4157     if (DO_UTF8(source)) {
4158         const U8 *const send = s + len;
4159         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4160
4161         /* All occurrences of these are to be moved to follow any other marks.
4162          * This is context-dependent.  We may not be passed enough context to
4163          * move the iota subscript beyond all of them, but we do the best we can
4164          * with what we're given.  The result is always better than if we
4165          * hadn't done this.  And, the problem would only arise if we are
4166          * passed a character without all its combining marks, which would be
4167          * the caller's mistake.  The information this is based on comes from a
4168          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4169          * itself) and so can't be checked properly to see if it ever gets
4170          * revised.  But the likelihood of it changing is remote */
4171         bool in_iota_subscript = FALSE;
4172
4173         while (s < send) {
4174             STRLEN u;
4175             STRLEN ulen;
4176             UV uv;
4177             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4178
4179                 /* A non-mark.  Time to output the iota subscript */
4180                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4181                 d += capital_iota_len;
4182                 in_iota_subscript = FALSE;
4183             }
4184
4185             /* Then handle the current character.  Get the changed case value
4186              * and copy it to the output buffer */
4187
4188             u = UTF8SKIP(s);
4189 #ifdef USE_LOCALE_CTYPE
4190             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4191 #else
4192             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4193 #endif
4194 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4195 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4196             if (uv == GREEK_CAPITAL_LETTER_IOTA
4197                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4198             {
4199                 in_iota_subscript = TRUE;
4200             }
4201             else {
4202                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4203                     /* If the eventually required minimum size outgrows the
4204                      * available space, we need to grow. */
4205                     const UV o = d - (U8*)SvPVX_const(dest);
4206
4207                     /* If someone uppercases one million U+03B0s we SvGROW()
4208                      * one million times.  Or we could try guessing how much to
4209                      * allocate without allocating too much.  Such is life.
4210                      * See corresponding comment in lc code for another option
4211                      * */
4212                     SvGROW(dest, min);
4213                     d = (U8*)SvPVX(dest) + o;
4214                 }
4215                 Copy(tmpbuf, d, ulen, U8);
4216                 d += ulen;
4217             }
4218             s += u;
4219         }
4220         if (in_iota_subscript) {
4221             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4222             d += capital_iota_len;
4223         }
4224         SvUTF8_on(dest);
4225         *d = '\0';
4226
4227         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4228     }
4229     else {      /* Not UTF-8 */
4230         if (len) {
4231             const U8 *const send = s + len;
4232
4233             /* Use locale casing if in locale; regular style if not treating
4234              * latin1 as having case; otherwise the latin1 casing.  Do the
4235              * whole thing in a tight loop, for speed, */
4236 #ifdef USE_LOCALE_CTYPE
4237             if (IN_LC_RUNTIME(LC_CTYPE)) {
4238                 if (IN_UTF8_CTYPE_LOCALE) {
4239                     goto do_uni_rules;
4240                 }
4241                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4242                 for (; s < send; d++, s++)
4243                     *d = (U8) toUPPER_LC(*s);
4244             }
4245             else
4246 #endif
4247                  if (! IN_UNI_8_BIT) {
4248                 for (; s < send; d++, s++) {
4249                     *d = toUPPER(*s);
4250                 }
4251             }
4252             else {
4253 #ifdef USE_LOCALE_CTYPE
4254           do_uni_rules:
4255 #endif
4256                 for (; s < send; d++, s++) {
4257                     *d = toUPPER_LATIN1_MOD(*s);
4258                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4259                         continue;
4260                     }
4261
4262                     /* The mainstream case is the tight loop above.  To avoid
4263                      * extra tests in that, all three characters that require
4264                      * special handling are mapped by the MOD to the one tested
4265                      * just above.
4266                      * Use the source to distinguish between the three cases */
4267
4268 #if    UNICODE_MAJOR_VERSION > 2                                        \
4269    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4270                                   && UNICODE_DOT_DOT_VERSION >= 8)
4271                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4272
4273                         /* uc() of this requires 2 characters, but they are
4274                          * ASCII.  If not enough room, grow the string */
4275                         if (SvLEN(dest) < ++min) {
4276                             const UV o = d - (U8*)SvPVX_const(dest);
4277                             SvGROW(dest, min);
4278                             d = (U8*)SvPVX(dest) + o;
4279                         }
4280                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4281                         continue;   /* Back to the tight loop; still in ASCII */
4282                     }
4283 #endif
4284
4285                     /* The other two special handling characters have their
4286                      * upper cases outside the latin1 range, hence need to be
4287                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4288                      * here we are somewhere in the middle of processing a
4289                      * non-UTF-8 string, and realize that we will have to convert
4290                      * the whole thing to UTF-8.  What to do?  There are
4291                      * several possibilities.  The simplest to code is to
4292                      * convert what we have so far, set a flag, and continue on
4293                      * in the loop.  The flag would be tested each time through
4294                      * the loop, and if set, the next character would be
4295                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4296                      * to slow down the mainstream case at all for this fairly
4297                      * rare case, so I didn't want to add a test that didn't
4298                      * absolutely have to be there in the loop, besides the
4299                      * possibility that it would get too complicated for
4300                      * optimizers to deal with.  Another possibility is to just
4301                      * give up, convert the source to UTF-8, and restart the
4302                      * function that way.  Another possibility is to convert
4303                      * both what has already been processed and what is yet to
4304                      * come separately to UTF-8, then jump into the loop that
4305                      * handles UTF-8.  But the most efficient time-wise of the
4306                      * ones I could think of is what follows, and turned out to
4307                      * not require much extra code.  */
4308
4309                     /* Convert what we have so far into UTF-8, telling the
4310                      * function that we know it should be converted, and to
4311                      * allow extra space for what we haven't processed yet.
4312                      * Assume the worst case space requirements for converting
4313                      * what we haven't processed so far: that it will require
4314                      * two bytes for each remaining source character, plus the
4315                      * NUL at the end.  This may cause the string pointer to
4316                      * move, so re-find it. */
4317
4318                     len = d - (U8*)SvPVX_const(dest);
4319                     SvCUR_set(dest, len);
4320                     len = sv_utf8_upgrade_flags_grow(dest,
4321                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4322                                                 (send -s) * 2 + 1);
4323                     d = (U8*)SvPVX(dest) + len;
4324
4325                     /* Now process the remainder of the source, converting to
4326                      * upper and UTF-8.  If a resulting byte is invariant in
4327                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4328                      * append it to the output. */
4329                     for (; s < send; s++) {
4330                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4331                         d += len;
4332                     }
4333
4334                     /* Here have processed the whole source; no need to continue
4335                      * with the outer loop.  Each character has been converted
4336                      * to upper case and converted to UTF-8 */
4337
4338                     break;
4339                 } /* End of processing all latin1-style chars */
4340             } /* End of processing all chars */
4341         } /* End of source is not empty */
4342
4343         if (source != dest) {
4344             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4345             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4346         }
4347     } /* End of isn't utf8 */
4348 #ifdef USE_LOCALE_CTYPE
4349     if (IN_LC_RUNTIME(LC_CTYPE)) {
4350         TAINT;
4351         SvTAINTED_on(dest);
4352     }
4353 #endif
4354     if (dest != source && SvTAINTED(source))
4355         SvTAINT(dest);
4356     SvSETMAGIC(dest);
4357     return NORMAL;
4358 }
4359
4360 PP(pp_lc)
4361 {
4362     dSP;
4363     SV *source = TOPs;
4364     STRLEN len;
4365     STRLEN min;
4366     SV *dest;
4367     const U8 *s;
4368     U8 *d;
4369
4370     SvGETMAGIC(source);
4371
4372     if (   (  SvPADTMP(source)
4373            || (  SvTEMP(source) && !SvSMAGICAL(source)
4374               && SvREFCNT(source) == 1  )
4375            )
4376         && !SvREADONLY(source) && SvPOK(source)
4377         && !DO_UTF8(source)) {
4378
4379         /* We can convert in place, as lowercasing anything in the latin1 range
4380          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4381         dest = source;
4382         s = d = (U8*)SvPV_force_nomg(source, len);
4383         min = len + 1;
4384     } else {
4385         dTARGET;
4386
4387         dest = TARG;
4388
4389         s = (const U8*)SvPV_nomg_const(source, len);
4390         min = len + 1;
4391
4392         SvUPGRADE(dest, SVt_PV);
4393         d = (U8*)SvGROW(dest, min);
4394         (void)SvPOK_only(dest);
4395
4396         SETs(dest);
4397     }
4398
4399     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4400        to check DO_UTF8 again here.  */
4401
4402     if (DO_UTF8(source)) {
4403         const U8 *const send = s + len;
4404         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4405
4406         while (s < send) {
4407             const STRLEN u = UTF8SKIP(s);
4408             STRLEN ulen;
4409
4410 #ifdef USE_LOCALE_CTYPE
4411             _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4412 #else
4413             _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4414 #endif
4415
4416             /* Here is where we would do context-sensitive actions.  See the
4417              * commit message for 86510fb15 for why there isn't any */
4418
4419             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4420
4421                 /* If the eventually required minimum size outgrows the
4422                  * available space, we need to grow. */
4423                 const UV o = d - (U8*)SvPVX_const(dest);
4424
4425                 /* If someone lowercases one million U+0130s we SvGROW() one
4426                  * million times.  Or we could try guessing how much to
4427                  * allocate without allocating too much.  Such is life.
4428                  * Another option would be to grow an extra byte or two more
4429                  * each time we need to grow, which would cut down the million
4430                  * to 500K, with little waste */
4431                 SvGROW(dest, min);
4432                 d = (U8*)SvPVX(dest) + o;
4433             }
4434
4435             /* Copy the newly lowercased letter to the output buffer we're
4436              * building */
4437             Copy(tmpbuf, d, ulen, U8);
4438             d += ulen;
4439             s += u;
4440         }   /* End of looping through the source string */
4441         SvUTF8_on(dest);
4442         *d = '\0';
4443         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4444     } else {    /* Not utf8 */
4445         if (len) {
4446             const U8 *const send = s + len;
4447
4448             /* Use locale casing if in locale; regular style if not treating
4449              * latin1 as having case; otherwise the latin1 casing.  Do the
4450              * whole thing in a tight loop, for speed, */
4451 #ifdef USE_LOCALE_CTYPE
4452             if (IN_LC_RUNTIME(LC_CTYPE)) {
4453                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4454                 for (; s < send; d++, s++)
4455                     *d = toLOWER_LC(*s);
4456             }
4457             else
4458 #endif
4459             if (! IN_UNI_8_BIT) {
4460                 for (; s < send; d++, s++) {
4461                     *d = toLOWER(*s);
4462                 }
4463             }
4464             else {
4465                 for (; s < send; d++, s++) {
4466                     *d = toLOWER_LATIN1(*s);
4467                 }
4468             }
4469         }
4470         if (source != dest) {
4471             *d = '\0';
4472             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4473         }
4474     }
4475 #ifdef USE_LOCALE_CTYPE
4476     if (IN_LC_RUNTIME(LC_CTYPE)) {
4477         TAINT;
4478         SvTAINTED_on(dest);
4479     }
4480 #endif
4481     if (dest != source && SvTAINTED(source))
4482         SvTAINT(dest);
4483     SvSETMAGIC(dest);
4484     return NORMAL;
4485 }
4486
4487 PP(pp_quotemeta)
4488 {
4489     dSP; dTARGET;
4490     SV * const sv = TOPs;
4491     STRLEN len;
4492     const char *s = SvPV_const(sv,len);
4493
4494     SvUTF8_off(TARG);                           /* decontaminate */
4495     if (len) {
4496         char *d;
4497         SvUPGRADE(TARG, SVt_PV);
4498         SvGROW(TARG, (len * 2) + 1);
4499         d = SvPVX(TARG);
4500         if (DO_UTF8(sv)) {
4501             while (len) {
4502                 STRLEN ulen = UTF8SKIP(s);
4503                 bool to_quote = FALSE;
4504
4505                 if (UTF8_IS_INVARIANT(*s)) {
4506                     if (_isQUOTEMETA(*s)) {
4507                         to_quote = TRUE;
4508                     }
4509                 }
4510                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4511                     if (
4512 #ifdef USE_LOCALE_CTYPE
4513                     /* In locale, we quote all non-ASCII Latin1 chars.
4514                      * Otherwise use the quoting rules */
4515
4516                     IN_LC_RUNTIME(LC_CTYPE)
4517                         ||
4518 #endif
4519                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4520                     {
4521                         to_quote = TRUE;
4522                     }
4523                 }
4524                 else if (is_QUOTEMETA_high(s)) {
4525                     to_quote = TRUE;
4526                 }
4527
4528                 if (to_quote) {
4529                     *d++ = '\\';
4530                 }
4531                 if (ulen > len)
4532                     ulen = len;
4533                 len -= ulen;
4534                 while (ulen--)
4535                     *d++ = *s++;
4536             }
4537             SvUTF8_on(TARG);
4538         }
4539         else if (IN_UNI_8_BIT) {
4540             while (len--) {
4541                 if (_isQUOTEMETA(*s))
4542                     *d++ = '\\';
4543                 *d++ = *s++;
4544             }
4545         }
4546         else {
4547             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4548              * including everything above ASCII */
4549             while (len--) {
4550                 if (!isWORDCHAR_A(*s))
4551                     *d++ = '\\';
4552                 *d++ = *s++;
4553             }
4554         }
4555         *d = '\0';
4556         SvCUR_set(TARG, d - SvPVX_const(TARG));
4557         (void)SvPOK_only_UTF8(TARG);
4558     }
4559     else
4560         sv_setpvn(TARG, s, len);
4561     SETTARG;
4562     return NORMAL;
4563 }
4564
4565 PP(pp_fc)
4566 {
4567     dTARGET;
4568     dSP;
4569     SV *source = TOPs;
4570     STRLEN len;
4571     STRLEN min;
4572     SV *dest;
4573     const U8 *s;
4574     const U8 *send;
4575     U8 *d;
4576     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4577 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4578    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4579                                       || UNICODE_DOT_DOT_VERSION > 0)
4580     const bool full_folding = TRUE; /* This variable is here so we can easily
4581                                        move to more generality later */
4582 #else
4583     const bool full_folding = FALSE;
4584 #endif
4585     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4586 #ifdef USE_LOCALE_CTYPE
4587                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4588 #endif
4589     ;
4590
4591     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4592      * You are welcome(?) -Hugmeir
4593      */
4594
4595     SvGETMAGIC(source);
4596
4597     dest = TARG;
4598
4599     if (SvOK(source)) {
4600         s = (const U8*)SvPV_nomg_const(source, len);
4601     } else {
4602         if (ckWARN(WARN_UNINITIALIZED))
4603             report_uninit(source);
4604         s = (const U8*)"";
4605         len = 0;
4606     }
4607
4608     min = len + 1;
4609
4610     SvUPGRADE(dest, SVt_PV);
4611     d = (U8*)SvGROW(dest, min);
4612     (void)SvPOK_only(dest);
4613
4614     SETs(dest);
4615
4616     send = s + len;
4617     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4618         while (s < send) {
4619             const STRLEN u = UTF8SKIP(s);
4620             STRLEN ulen;
4621
4622             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4623
4624             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4625                 const UV o = d - (U8*)SvPVX_const(dest);
4626                 SvGROW(dest, min);
4627                 d = (U8*)SvPVX(dest) + o;
4628             }
4629
4630             Copy(tmpbuf, d, ulen, U8);
4631             d += ulen;
4632             s += u;
4633         }
4634         SvUTF8_on(dest);
4635     } /* Unflagged string */
4636     else if (len) {
4637 #ifdef USE_LOCALE_CTYPE
4638         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4639             if (IN_UTF8_CTYPE_LOCALE) {
4640                 goto do_uni_folding;
4641             }
4642             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4643             for (; s < send; d++, s++)
4644                 *d = (U8) toFOLD_LC(*s);
4645         }
4646         else
4647 #endif
4648         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4649             for (; s < send; d++, s++)
4650                 *d = toFOLD(*s);
4651         }
4652         else {
4653 #ifdef USE_LOCALE_CTYPE
4654       do_uni_folding:
4655 #endif
4656             /* For ASCII and the Latin-1 range, there's only two troublesome
4657              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4658              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4659              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4660              * For the rest, the casefold is their lowercase.  */
4661             for (; s < send; d++, s++) {
4662                 if (*s == MICRO_SIGN) {
4663                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4664                      * which is outside of the latin-1 range. There's a couple
4665                      * of ways to deal with this -- khw discusses them in
4666                      * pp_lc/uc, so go there :) What we do here is upgrade what
4667                      * we had already casefolded, then enter an inner loop that
4668                      * appends the rest of the characters as UTF-8. */
4669                     len = d - (U8*)SvPVX_const(dest);
4670                     SvCUR_set(dest, len);
4671                     len = sv_utf8_upgrade_flags_grow(dest,
4672                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4673                                                 /* The max exp