pp.c

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