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