pp.c

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