pp.c

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