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