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