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