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