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             SvREFCNT_inc_void_NN(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_simple(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             SvREFCNT_inc_void_NN(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         SvREFCNT_inc_void_NN(sv);
 499     }
 500     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 501         sv = newSVsv(sv);
 502     else {
 503         SvTEMP_off(sv);
 504         SvREFCNT_inc_void_NN(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_simple(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 (isGV_with_GP(sv))
3020                     SvPV_force_nolen(sv);
3021                 else if (SvOK(sv))      /* is it defined ? */
3022                     (void)SvPOK_only_UTF8(sv);
3023                 else
3024                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3025             }
3026
3027             if (SvTYPE(TARG) < SVt_PVLV) {
3028                 sv_upgrade(TARG, SVt_PVLV);
3029                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3030             }
3031             else
3032                 SvOK_off(TARG);
3033
3034             LvTYPE(TARG) = 'x';
3035             if (LvTARG(TARG) != sv) {
3036                 if (LvTARG(TARG))
3037                     SvREFCNT_dec(LvTARG(TARG));
3038                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3039             }
3040             LvTARGOFF(TARG) = upos;
3041             LvTARGLEN(TARG) = urem;
3042         }
3043     }
3044     SPAGAIN;
3045     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3046     RETURN;
3047 }
3048
3049 PP(pp_vec)
3050 {
3051     dVAR; dSP; dTARGET;
3052     register const IV size   = POPi;
3053     register const IV offset = POPi;
3054     register SV * const src = POPs;
3055     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3056
3057     SvTAINTED_off(TARG);                /* decontaminate */
3058     if (lvalue) {                       /* it's an lvalue! */
3059         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3060             TARG = sv_newmortal();
3061         if (SvTYPE(TARG) < SVt_PVLV) {
3062             sv_upgrade(TARG, SVt_PVLV);
3063             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3064         }
3065         LvTYPE(TARG) = 'v';
3066         if (LvTARG(TARG) != src) {
3067             if (LvTARG(TARG))
3068                 SvREFCNT_dec(LvTARG(TARG));
3069             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3070         }
3071         LvTARGOFF(TARG) = offset;
3072         LvTARGLEN(TARG) = size;
3073     }
3074
3075     sv_setuv(TARG, do_vecget(src, offset, size));
3076     PUSHs(TARG);
3077     RETURN;
3078 }
3079
3080 PP(pp_index)
3081 {
3082     dVAR; dSP; dTARGET;
3083     SV *big;
3084     SV *little;
3085     SV *temp = NULL;
3086     STRLEN biglen;
3087     STRLEN llen = 0;
3088     I32 offset;
3089     I32 retval;
3090     const char *tmps;
3091     const char *tmps2;
3092     const I32 arybase = PL_curcop->cop_arybase;
3093     bool big_utf8;
3094     bool little_utf8;
3095     const bool is_index = PL_op->op_type == OP_INDEX;
3096
3097     if (MAXARG >= 3) {
3098         /* arybase is in characters, like offset, so combine prior to the
3099            UTF-8 to bytes calculation.  */
3100         offset = POPi - arybase;
3101     }
3102     little = POPs;
3103     big = POPs;
3104     big_utf8 = DO_UTF8(big);
3105     little_utf8 = DO_UTF8(little);
3106     if (big_utf8 ^ little_utf8) {
3107         /* One needs to be upgraded.  */
3108         if (little_utf8 && !PL_encoding) {
3109             /* Well, maybe instead we might be able to downgrade the small
3110                string?  */
3111             STRLEN little_len;
3112             const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3113             char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3114                                                      &little_utf8);
3115             if (little_utf8) {
3116                 /* If the large string is ISO-8859-1, and it's not possible to
3117                    convert the small string to ISO-8859-1, then there is no
3118                    way that it could be found anywhere by index.  */
3119                 retval = -1;
3120                 goto fail;
3121             }
3122
3123             /* At this point, pv is a malloc()ed string. So donate it to temp
3124                to ensure it will get free()d  */
3125             little = temp = newSV(0);
3126             sv_usepvn(temp, pv, little_len);
3127         } else {
3128             SV * const bytes = little_utf8 ? big : little;
3129             STRLEN len;
3130             const char * const p = SvPV_const(bytes, len);
3131
3132             temp = newSVpvn(p, len);
3133
3134             if (PL_encoding) {
3135                 sv_recode_to_utf8(temp, PL_encoding);
3136             } else {
3137                 sv_utf8_upgrade(temp);
3138             }
3139             if (little_utf8) {
3140                 big = temp;
3141                 big_utf8 = TRUE;
3142             } else {
3143                 little = temp;
3144             }
3145         }
3146     }
3147     /* Don't actually need the NULL initialisation, but it keeps gcc quiet.  */
3148     tmps2 = is_index ? NULL : SvPV_const(little, llen);
3149     tmps = SvPV_const(big, biglen);
3150
3151     if (MAXARG < 3)
3152         offset = is_index ? 0 : biglen;
3153     else {
3154         if (big_utf8 && offset > 0)
3155             sv_pos_u2b(big, &offset, 0);
3156         offset += llen;
3157     }
3158     if (offset < 0)
3159         offset = 0;
3160     else if (offset > (I32)biglen)
3161         offset = biglen;
3162     if (!(tmps2 = is_index
3163           ? fbm_instr((unsigned char*)tmps + offset,
3164                       (unsigned char*)tmps + biglen, little, 0)
3165           : rninstr(tmps,  tmps  + offset,
3166                     tmps2, tmps2 + llen)))
3167         retval = -1;
3168     else {
3169         retval = tmps2 - tmps;
3170         if (retval > 0 && big_utf8)
3171             sv_pos_b2u(big, &retval);
3172     }
3173     if (temp)
3174         SvREFCNT_dec(temp);
3175  fail:
3176     PUSHi(retval + arybase);
3177     RETURN;
3178 }
3179
3180 PP(pp_sprintf)
3181 {
3182     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3183     do_sprintf(TARG, SP-MARK, MARK+1);
3184     TAINT_IF(SvTAINTED(TARG));
3185     SP = ORIGMARK;
3186     PUSHTARG;
3187     RETURN;
3188 }
3189
3190 PP(pp_ord)
3191 {
3192     dVAR; dSP; dTARGET;
3193     SV *argsv = POPs;
3194     STRLEN len;
3195     const U8 *s = (U8*)SvPV_const(argsv, len);
3196     SV *tmpsv;
3197
3198     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3199         tmpsv = sv_2mortal(newSVsv(argsv));
3200         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3201         argsv = tmpsv;
3202     }
3203
3204     XPUSHu(DO_UTF8(argsv) ?
3205            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3206            (*s & 0xff));
3207
3208     RETURN;
3209 }
3210
3211 PP(pp_chr)
3212 {
3213     dVAR; dSP; dTARGET;
3214     char *tmps;
3215     UV value;
3216
3217     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3218          ||
3219          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3220         if (IN_BYTES) {
3221             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3222         } else {
3223             (void) POPs; /* Ignore the argument value. */
3224             value = UNICODE_REPLACEMENT;
3225         }
3226     } else {
3227         value = POPu;
3228     }
3229
3230     SvUPGRADE(TARG,SVt_PV);
3231
3232     if (value > 255 && !IN_BYTES) {
3233         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3234         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3235         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3236         *tmps = '\0';
3237         (void)SvPOK_only(TARG);
3238         SvUTF8_on(TARG);
3239         XPUSHs(TARG);
3240         RETURN;
3241     }
3242
3243     SvGROW(TARG,2);
3244     SvCUR_set(TARG, 1);
3245     tmps = SvPVX(TARG);
3246     *tmps++ = (char)value;
3247     *tmps = '\0';
3248     (void)SvPOK_only(TARG);
3249     if (PL_encoding && !IN_BYTES) {
3250         sv_recode_to_utf8(TARG, PL_encoding);
3251         tmps = SvPVX(TARG);
3252         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3253             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3254             SvGROW(TARG, 3);
3255             tmps = SvPVX(TARG);
3256             SvCUR_set(TARG, 2);
3257             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3258             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3259             *tmps = '\0';
3260             SvUTF8_on(TARG);
3261         }
3262     }
3263     XPUSHs(TARG);
3264     RETURN;
3265 }
3266
3267 PP(pp_crypt)
3268 {
3269 #ifdef HAS_CRYPT
3270     dVAR; dSP; dTARGET;
3271     dPOPTOPssrl;
3272     STRLEN len;
3273     const char *tmps = SvPV_const(left, len);
3274
3275     if (DO_UTF8(left)) {
3276          /* If Unicode, try to downgrade.
3277           * If not possible, croak.
3278           * Yes, we made this up.  */
3279          SV* const tsv = sv_2mortal(newSVsv(left));
3280
3281          SvUTF8_on(tsv);
3282          sv_utf8_downgrade(tsv, FALSE);
3283          tmps = SvPV_const(tsv, len);
3284     }
3285 #   ifdef USE_ITHREADS
3286 #     ifdef HAS_CRYPT_R
3287     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3288       /* This should be threadsafe because in ithreads there is only
3289        * one thread per interpreter.  If this would not be true,
3290        * we would need a mutex to protect this malloc. */
3291         PL_reentrant_buffer->_crypt_struct_buffer =
3292           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3293 #if defined(__GLIBC__) || defined(__EMX__)
3294         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3295             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3296             /* work around glibc-2.2.5 bug */
3297             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3298         }
3299 #endif
3300     }
3301 #     endif /* HAS_CRYPT_R */
3302 #   endif /* USE_ITHREADS */
3303 #   ifdef FCRYPT
3304     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3305 #   else
3306     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3307 #   endif
3308     SETs(TARG);
3309     RETURN;
3310 #else
3311     DIE(aTHX_
3312       "The crypt() function is unimplemented due to excessive paranoia.");
3313 #endif
3314 }
3315
3316 PP(pp_ucfirst)
3317 {
3318     dVAR;
3319     dSP;
3320     SV *sv = TOPs;
3321     const U8 *s;
3322     STRLEN slen;
3323     const int op_type = PL_op->op_type;
3324
3325     SvGETMAGIC(sv);
3326     if (DO_UTF8(sv) &&
3327         (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3328         UTF8_IS_START(*s)) {
3329         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3330         STRLEN ulen;
3331         STRLEN tculen;
3332
3333         utf8_to_uvchr(s, &ulen);
3334         if (op_type == OP_UCFIRST) {
3335             toTITLE_utf8(s, tmpbuf, &tculen);
3336         } else {
3337             toLOWER_utf8(s, tmpbuf, &tculen);
3338         }
3339
3340         if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3341             dTARGET;
3342             /* slen is the byte length of the whole SV.
3343              * ulen is the byte length of the original Unicode character
3344              * stored as UTF-8 at s.
3345              * tculen is the byte length of the freshly titlecased (or
3346              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3347              * We first set the result to be the titlecased (/lowercased)
3348              * character, and then append the rest of the SV data. */
3349             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3350             if (slen > ulen)
3351                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3352             SvUTF8_on(TARG);
3353             sv = TARG;
3354             SETs(sv);
3355         }
3356         else {
3357             s = (U8*)SvPV_force_nomg(sv, slen);
3358             Copy(tmpbuf, s, tculen, U8);
3359         }
3360     }
3361     else {
3362         U8 *s1;
3363         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3364             dTARGET;
3365             SvUTF8_off(TARG);                           /* decontaminate */
3366             sv_setsv_nomg(TARG, sv);
3367             sv = TARG;
3368             SETs(sv);
3369         }
3370         s1 = (U8*)SvPV_force_nomg(sv, slen);
3371         if (*s1) {
3372             if (IN_LOCALE_RUNTIME) {
3373                 TAINT;
3374                 SvTAINTED_on(sv);
3375                 *s1 = (op_type == OP_UCFIRST)
3376                     ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3377             }
3378             else
3379                 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3380         }
3381     }
3382     SvSETMAGIC(sv);
3383     RETURN;
3384 }
3385
3386 PP(pp_uc)
3387 {
3388     dVAR;
3389     dSP;
3390     SV *sv = TOPs;
3391     STRLEN len;
3392
3393     SvGETMAGIC(sv);
3394     if (DO_UTF8(sv)) {
3395         dTARGET;
3396         STRLEN ulen;
3397         register U8 *d;
3398         const U8 *s;
3399         const U8 *send;
3400         U8 tmpbuf[UTF8_MAXBYTES+1];
3401
3402         s = (const U8*)SvPV_nomg_const(sv,len);
3403         if (!len) {
3404             SvUTF8_off(TARG);                           /* decontaminate */
3405             sv_setpvn(TARG, "", 0);
3406             sv = TARG;
3407             SETs(sv);
3408         }
3409         else {
3410             STRLEN min = len + 1;
3411
3412             SvUPGRADE(TARG, SVt_PV);
3413             SvGROW(TARG, min);
3414             (void)SvPOK_only(TARG);
3415             d = (U8*)SvPVX(TARG);
3416             send = s + len;
3417             while (s < send) {
3418                 STRLEN u = UTF8SKIP(s);
3419
3420                 toUPPER_utf8(s, tmpbuf, &ulen);
3421                 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3422                     /* If the eventually required minimum size outgrows
3423                      * the available space, we need to grow. */
3424                     const UV o = d - (U8*)SvPVX_const(TARG);
3425
3426                     /* If someone uppercases one million U+03B0s we
3427                      * SvGROW() one million times.  Or we could try
3428                      * guessing how much to allocate without allocating
3429                      * too much. Such is life. */
3430                     SvGROW(TARG, min);
3431                     d = (U8*)SvPVX(TARG) + o;
3432                 }
3433                 Copy(tmpbuf, d, ulen, U8);
3434                 d += ulen;
3435                 s += u;
3436             }
3437             *d = '\0';
3438             SvUTF8_on(TARG);
3439             SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3440             sv = TARG;
3441             SETs(sv);
3442         }
3443     }
3444     else {
3445         U8 *s;
3446         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3447             dTARGET;
3448             SvUTF8_off(TARG);                           /* decontaminate */
3449             sv_setsv_nomg(TARG, sv);
3450             sv = TARG;
3451             SETs(sv);
3452         }
3453         s = (U8*)SvPV_force_nomg(sv, len);
3454         if (len) {
3455             register const U8 *send = s + len;
3456
3457             if (IN_LOCALE_RUNTIME) {
3458                 TAINT;
3459                 SvTAINTED_on(sv);
3460                 for (; s < send; s++)
3461                     *s = toUPPER_LC(*s);
3462             }
3463             else {
3464                 for (; s < send; s++)
3465                     *s = toUPPER(*s);
3466             }
3467         }
3468     }
3469     SvSETMAGIC(sv);
3470     RETURN;
3471 }
3472
3473 PP(pp_lc)
3474 {
3475     dVAR;
3476     dSP;
3477     SV *sv = TOPs;
3478     STRLEN len;
3479
3480     SvGETMAGIC(sv);
3481     if (DO_UTF8(sv)) {
3482         dTARGET;
3483         const U8 *s;
3484         STRLEN ulen;
3485         register U8 *d;
3486         const U8 *send;
3487         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3488
3489         s = (const U8*)SvPV_nomg_const(sv,len);
3490         if (!len) {
3491             SvUTF8_off(TARG);                           /* decontaminate */
3492             sv_setpvn(TARG, "", 0);
3493             sv = TARG;
3494             SETs(sv);
3495         }
3496         else {
3497             STRLEN min = len + 1;
3498
3499             SvUPGRADE(TARG, SVt_PV);
3500             SvGROW(TARG, min);
3501             (void)SvPOK_only(TARG);
3502             d = (U8*)SvPVX(TARG);
3503             send = s + len;
3504             while (s < send) {
3505                 const STRLEN u = UTF8SKIP(s);
3506                 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3507
3508 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3509                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3510                     /*EMPTY*/
3511                      /*
3512                       * Now if the sigma is NOT followed by
3513                       * /$ignorable_sequence$cased_letter/;
3514                       * and it IS preceded by
3515                       * /$cased_letter$ignorable_sequence/;
3516                       * where $ignorable_sequence is
3517                       * [\x{2010}\x{AD}\p{Mn}]*
3518                       * and $cased_letter is
3519                       * [\p{Ll}\p{Lo}\p{Lt}]
3520                       * then it should be mapped to 0x03C2,
3521                       * (GREEK SMALL LETTER FINAL SIGMA),
3522                       * instead of staying 0x03A3.
3523                       * "should be": in other words,
3524                       * this is not implemented yet.
3525                       * See lib/unicore/SpecialCasing.txt.
3526                       */
3527                 }
3528                 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3529                     /* If the eventually required minimum size outgrows
3530                      * the available space, we need to grow. */
3531                     const UV o = d - (U8*)SvPVX_const(TARG);
3532
3533                     /* If someone lowercases one million U+0130s we
3534                      * SvGROW() one million times.  Or we could try
3535                      * guessing how much to allocate without allocating.
3536                      * too much.  Such is life. */
3537                     SvGROW(TARG, min);
3538                     d = (U8*)SvPVX(TARG) + o;
3539                 }
3540                 Copy(tmpbuf, d, ulen, U8);
3541                 d += ulen;
3542                 s += u;
3543             }
3544             *d = '\0';
3545             SvUTF8_on(TARG);
3546             SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3547             sv = TARG;
3548             SETs(sv);
3549         }
3550     }
3551     else {
3552         U8 *s;
3553         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3554             dTARGET;
3555             SvUTF8_off(TARG);                           /* decontaminate */
3556             sv_setsv_nomg(TARG, sv);
3557             sv = TARG;
3558             SETs(sv);
3559         }
3560
3561         s = (U8*)SvPV_force_nomg(sv, len);
3562         if (len) {
3563             register const U8 * const send = s + len;
3564
3565             if (IN_LOCALE_RUNTIME) {
3566                 TAINT;
3567                 SvTAINTED_on(sv);
3568                 for (; s < send; s++)
3569                     *s = toLOWER_LC(*s);
3570             }
3571             else {
3572                 for (; s < send; s++)
3573                     *s = toLOWER(*s);
3574             }
3575         }
3576     }
3577     SvSETMAGIC(sv);
3578     RETURN;
3579 }
3580
3581 PP(pp_quotemeta)
3582 {
3583     dVAR; dSP; dTARGET;
3584     SV * const sv = TOPs;
3585     STRLEN len;
3586     register const char *s = SvPV_const(sv,len);
3587
3588     SvUTF8_off(TARG);                           /* decontaminate */
3589     if (len) {
3590         register char *d;
3591         SvUPGRADE(TARG, SVt_PV);
3592         SvGROW(TARG, (len * 2) + 1);
3593         d = SvPVX(TARG);
3594         if (DO_UTF8(sv)) {
3595             while (len) {
3596                 if (UTF8_IS_CONTINUED(*s)) {
3597                     STRLEN ulen = UTF8SKIP(s);
3598                     if (ulen > len)
3599                         ulen = len;
3600                     len -= ulen;
3601                     while (ulen--)
3602                         *d++ = *s++;
3603                 }
3604                 else {
3605                     if (!isALNUM(*s))
3606                         *d++ = '\\';
3607                     *d++ = *s++;
3608                     len--;
3609                 }
3610             }
3611             SvUTF8_on(TARG);
3612         }
3613         else {
3614             while (len--) {
3615                 if (!isALNUM(*s))
3616                     *d++ = '\\';
3617                 *d++ = *s++;
3618             }
3619         }
3620         *d = '\0';
3621         SvCUR_set(TARG, d - SvPVX_const(TARG));
3622         (void)SvPOK_only_UTF8(TARG);
3623     }
3624     else
3625         sv_setpvn(TARG, s, len);
3626     SETs(TARG);
3627     if (SvSMAGICAL(TARG))
3628         mg_set(TARG);
3629     RETURN;
3630 }
3631
3632 /* Arrays. */
3633
3634 PP(pp_aslice)
3635 {
3636     dVAR; dSP; dMARK; dORIGMARK;
3637     register AV* const av = (AV*)POPs;
3638     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3639
3640     if (SvTYPE(av) == SVt_PVAV) {
3641         const I32 arybase = PL_curcop->cop_arybase;
3642         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3643             register SV **svp;
3644             I32 max = -1;
3645             for (svp = MARK + 1; svp <= SP; svp++) {
3646                 const I32 elem = SvIVx(*svp);
3647                 if (elem > max)
3648                     max = elem;
3649             }
3650             if (max > AvMAX(av))
3651                 av_extend(av, max);
3652         }
3653         while (++MARK <= SP) {
3654             register SV **svp;
3655             I32 elem = SvIVx(*MARK);
3656
3657             if (elem > 0)
3658                 elem -= arybase;
3659             svp = av_fetch(av, elem, lval);
3660             if (lval) {
3661                 if (!svp || *svp == &PL_sv_undef)
3662                     DIE(aTHX_ PL_no_aelem, elem);
3663                 if (PL_op->op_private & OPpLVAL_INTRO)
3664                     save_aelem(av, elem, svp);
3665             }
3666             *MARK = svp ? *svp : &PL_sv_undef;
3667         }
3668     }
3669     if (GIMME != G_ARRAY) {
3670         MARK = ORIGMARK;
3671         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3672         SP = MARK;
3673     }
3674     RETURN;
3675 }
3676
3677 /* Associative arrays. */
3678
3679 PP(pp_each)
3680 {
3681     dVAR;
3682     dSP;
3683     HV * const hash = (HV*)POPs;
3684     HE *entry;
3685     const I32 gimme = GIMME_V;
3686
3687     PUTBACK;
3688     /* might clobber stack_sp */
3689     entry = hv_iternext(hash);
3690     SPAGAIN;
3691
3692     EXTEND(SP, 2);
3693     if (entry) {
3694         SV* const sv = hv_iterkeysv(entry);
3695         PUSHs(sv);      /* won't clobber stack_sp */
3696         if (gimme == G_ARRAY) {
3697             SV *val;
3698             PUTBACK;
3699             /* might clobber stack_sp */
3700             val = hv_iterval(hash, entry);
3701             SPAGAIN;
3702             PUSHs(val);
3703         }
3704     }
3705     else if (gimme == G_SCALAR)
3706         RETPUSHUNDEF;
3707
3708     RETURN;
3709 }
3710
3711 PP(pp_delete)
3712 {
3713     dVAR;
3714     dSP;
3715     const I32 gimme = GIMME_V;
3716     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3717
3718     if (PL_op->op_private & OPpSLICE) {
3719         dMARK; dORIGMARK;
3720         HV * const hv = (HV*)POPs;
3721         const U32 hvtype = SvTYPE(hv);
3722         if (hvtype == SVt_PVHV) {                       /* hash element */
3723             while (++MARK <= SP) {
3724                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3725                 *MARK = sv ? sv : &PL_sv_undef;
3726             }
3727         }
3728         else if (hvtype == SVt_PVAV) {                  /* array element */
3729             if (PL_op->op_flags & OPf_SPECIAL) {
3730                 while (++MARK <= SP) {
3731                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3732                     *MARK = sv ? sv : &PL_sv_undef;
3733                 }
3734             }
3735         }
3736         else
3737             DIE(aTHX_ "Not a HASH reference");
3738         if (discard)
3739             SP = ORIGMARK;
3740         else if (gimme == G_SCALAR) {
3741             MARK = ORIGMARK;
3742             if (SP > MARK)
3743                 *++MARK = *SP;
3744             else
3745                 *++MARK = &PL_sv_undef;
3746             SP = MARK;
3747         }
3748     }
3749     else {
3750         SV *keysv = POPs;
3751         HV * const hv = (HV*)POPs;
3752         SV *sv;
3753         if (SvTYPE(hv) == SVt_PVHV)
3754             sv = hv_delete_ent(hv, keysv, discard, 0);
3755         else if (SvTYPE(hv) == SVt_PVAV) {
3756             if (PL_op->op_flags & OPf_SPECIAL)
3757                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3758             else
3759                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3760         }
3761         else
3762             DIE(aTHX_ "Not a HASH reference");
3763         if (!sv)
3764             sv = &PL_sv_undef;
3765         if (!discard)
3766             PUSHs(sv);
3767     }
3768     RETURN;
3769 }
3770
3771 PP(pp_exists)
3772 {
3773     dVAR;
3774     dSP;
3775     SV *tmpsv;
3776     HV *hv;
3777
3778     if (PL_op->op_private & OPpEXISTS_SUB) {
3779         GV *gv;
3780         SV * const sv = POPs;
3781         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3782         if (cv)
3783             RETPUSHYES;
3784         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3785             RETPUSHYES;
3786         RETPUSHNO;
3787     }
3788     tmpsv = POPs;
3789     hv = (HV*)POPs;
3790     if (SvTYPE(hv) == SVt_PVHV) {
3791         if (hv_exists_ent(hv, tmpsv, 0))
3792             RETPUSHYES;
3793     }
3794     else if (SvTYPE(hv) == SVt_PVAV) {
3795         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3796             if (av_exists((AV*)hv, SvIV(tmpsv)))
3797                 RETPUSHYES;
3798         }
3799     }
3800     else {
3801         DIE(aTHX_ "Not a HASH reference");
3802     }
3803     RETPUSHNO;
3804 }
3805
3806 PP(pp_hslice)
3807 {
3808     dVAR; dSP; dMARK; dORIGMARK;
3809     register HV * const hv = (HV*)POPs;
3810     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3811     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3812     bool other_magic = FALSE;
3813
3814     if (localizing) {
3815         MAGIC *mg;
3816         HV *stash;
3817
3818         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3819             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3820              /* Try to preserve the existenceness of a tied hash
3821               * element by using EXISTS and DELETE if possible.
3822               * Fallback to FETCH and STORE otherwise */
3823              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3824              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3825              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3826     }
3827
3828     while (++MARK <= SP) {
3829         SV * const keysv = *MARK;
3830         SV **svp;
3831         HE *he;
3832         bool preeminent = FALSE;
3833
3834         if (localizing) {
3835             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3836                 hv_exists_ent(hv, keysv, 0);
3837         }
3838
3839         he = hv_fetch_ent(hv, keysv, lval, 0);
3840         svp = he ? &HeVAL(he) : 0;
3841
3842         if (lval) {
3843             if (!svp || *svp == &PL_sv_undef) {
3844                 DIE(aTHX_ PL_no_helem_sv, keysv);
3845             }
3846             if (localizing) {
3847                 if (preeminent)
3848                     save_helem(hv, keysv, svp);
3849                 else {
3850                     STRLEN keylen;
3851                     const char *key = SvPV_const(keysv, keylen);
3852                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
3853                 }
3854             }
3855         }
3856         *MARK = svp ? *svp : &PL_sv_undef;
3857     }
3858     if (GIMME != G_ARRAY) {
3859         MARK = ORIGMARK;
3860         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3861         SP = MARK;
3862     }
3863     RETURN;
3864 }
3865
3866 /* List operators. */
3867
3868 PP(pp_list)
3869 {
3870     dVAR; dSP; dMARK;
3871     if (GIMME != G_ARRAY) {
3872         if (++MARK <= SP)
3873             *MARK = *SP;                /* unwanted list, return last item */
3874         else
3875             *MARK = &PL_sv_undef;
3876         SP = MARK;
3877     }
3878     RETURN;
3879 }
3880
3881 PP(pp_lslice)
3882 {
3883     dVAR;
3884     dSP;
3885     SV ** const lastrelem = PL_stack_sp;
3886     SV ** const lastlelem = PL_stack_base + POPMARK;
3887     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3888     register SV ** const firstrelem = lastlelem + 1;
3889     const I32 arybase = PL_curcop->cop_arybase;
3890     I32 is_something_there = PL_op->op_flags & OPf_MOD;
3891
3892     register const I32 max = lastrelem - lastlelem;
3893     register SV **lelem;
3894
3895     if (GIMME != G_ARRAY) {
3896         I32 ix = SvIVx(*lastlelem);
3897         if (ix < 0)
3898             ix += max;
3899         else
3900             ix -= arybase;
3901         if (ix < 0 || ix >= max)
3902             *firstlelem = &PL_sv_undef;
3903         else
3904             *firstlelem = firstrelem[ix];
3905         SP = firstlelem;
3906         RETURN;
3907     }
3908
3909     if (max == 0) {
3910         SP = firstlelem - 1;
3911         RETURN;
3912     }
3913
3914     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3915         I32 ix = SvIVx(*lelem);
3916         if (ix < 0)
3917             ix += max;
3918         else
3919             ix -= arybase;
3920         if (ix < 0 || ix >= max)
3921             *lelem = &PL_sv_undef;
3922         else {
3923             is_something_there = TRUE;
3924             if (!(*lelem = firstrelem[ix]))
3925                 *lelem = &PL_sv_undef;
3926         }
3927     }
3928     if (is_something_there)
3929         SP = lastlelem;
3930     else
3931         SP = firstlelem - 1;
3932     RETURN;
3933 }
3934
3935 PP(pp_anonlist)
3936 {
3937     dVAR; dSP; dMARK; dORIGMARK;
3938     const I32 items = SP - MARK;
3939     SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3940     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3941     XPUSHs(av);
3942     RETURN;
3943 }
3944
3945 PP(pp_anonhash)
3946 {
3947     dVAR; dSP; dMARK; dORIGMARK;
3948     HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3949
3950     while (MARK < SP) {
3951         SV * const key = *++MARK;
3952         SV * const val = newSV(0);
3953         if (MARK < SP)
3954             sv_setsv(val, *++MARK);
3955         else if (ckWARN(WARN_MISC))
3956             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3957         (void)hv_store_ent(hv,key,val,0);
3958     }
3959     SP = ORIGMARK;
3960     XPUSHs((SV*)hv);
3961     RETURN;
3962 }
3963
3964 PP(pp_splice)
3965 {
3966     dVAR; dSP; dMARK; dORIGMARK;
3967     register AV *ary = (AV*)*++MARK;
3968     register SV **src;
3969     register SV **dst;
3970     register I32 i;
3971     register I32 offset;
3972     register I32 length;
3973     I32 newlen;
3974     I32 after;
3975     I32 diff;
3976     SV **tmparyval = NULL;
3977     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
3978
3979     if (mg) {
3980         *MARK-- = SvTIED_obj((SV*)ary, mg);
3981         PUSHMARK(MARK);
3982         PUTBACK;
3983         ENTER;
3984         call_method("SPLICE",GIMME_V);
3985         LEAVE;
3986         SPAGAIN;
3987         RETURN;
3988     }
3989
3990     SP++;
3991
3992     if (++MARK < SP) {
3993         offset = i = SvIVx(*MARK);
3994         if (offset < 0)
3995             offset += AvFILLp(ary) + 1;
3996         else
3997             offset -= PL_curcop->cop_arybase;
3998         if (offset < 0)
3999             DIE(aTHX_ PL_no_aelem, i);
4000         if (++MARK < SP) {
4001             length = SvIVx(*MARK++);
4002             if (length < 0) {
4003                 length += AvFILLp(ary) - offset + 1;
4004                 if (length < 0)
4005                     length = 0;
4006             }
4007         }
4008         else
4009             length = AvMAX(ary) + 1;            /* close enough to infinity */
4010     }
4011     else {
4012         offset = 0;
4013         length = AvMAX(ary) + 1;
4014     }
4015     if (offset > AvFILLp(ary) + 1) {
4016         if (ckWARN(WARN_MISC))
4017             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4018         offset = AvFILLp(ary) + 1;
4019     }
4020     after = AvFILLp(ary) + 1 - (offset + length);
4021     if (after < 0) {                            /* not that much array */
4022         length += after;                        /* offset+length now in array */
4023         after = 0;
4024         if (!AvALLOC(ary))
4025             av_extend(ary, 0);
4026     }
4027
4028     /* At this point, MARK .. SP-1 is our new LIST */
4029
4030     newlen = SP - MARK;
4031     diff = newlen - length;
4032     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4033         av_reify(ary);
4034
4035     /* make new elements SVs now: avoid problems if they're from the array */
4036     for (dst = MARK, i = newlen; i; i--) {
4037         SV * const h = *dst;
4038         *dst++ = newSVsv(h);
4039     }
4040
4041     if (diff < 0) {                             /* shrinking the area */
4042         if (newlen) {
4043             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4044             Copy(MARK, tmparyval, newlen, SV*);
4045         }
4046
4047         MARK = ORIGMARK + 1;
4048         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4049             MEXTEND(MARK, length);
4050             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4051             if (AvREAL(ary)) {
4052                 EXTEND_MORTAL(length);
4053                 for (i = length, dst = MARK; i; i--) {
4054                     sv_2mortal(*dst);   /* free them eventualy */
4055                     dst++;
4056                 }
4057             }
4058             MARK += length - 1;
4059         }
4060         else {
4061             *MARK = AvARRAY(ary)[offset+length-1];
4062             if (AvREAL(ary)) {
4063                 sv_2mortal(*MARK);
4064                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4065                     SvREFCNT_dec(*dst++);       /* free them now */
4066             }
4067         }
4068         AvFILLp(ary) += diff;
4069
4070         /* pull up or down? */
4071
4072         if (offset < after) {                   /* easier to pull up */
4073             if (offset) {                       /* esp. if nothing to pull */
4074                 src = &AvARRAY(ary)[offset-1];
4075                 dst = src - diff;               /* diff is negative */
4076                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4077                     *dst-- = *src--;
4078             }
4079             dst = AvARRAY(ary);
4080             SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4081             AvMAX(ary) += diff;
4082         }
4083         else {
4084             if (after) {                        /* anything to pull down? */
4085                 src = AvARRAY(ary) + offset + length;
4086                 dst = src + diff;               /* diff is negative */
4087                 Move(src, dst, after, SV*);
4088             }
4089             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4090                                                 /* avoid later double free */
4091         }
4092         i = -diff;
4093         while (i)
4094             dst[--i] = &PL_sv_undef;
4095
4096         if (newlen) {
4097             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4098             Safefree(tmparyval);
4099         }
4100     }
4101     else {                                      /* no, expanding (or same) */
4102         if (length) {
4103             Newx(tmparyval, length, SV*);       /* so remember deletion */
4104             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4105         }
4106
4107         if (diff > 0) {                         /* expanding */
4108
4109             /* push up or down? */
4110
4111             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4112                 if (offset) {
4113                     src = AvARRAY(ary);
4114                     dst = src - diff;
4115                     Move(src, dst, offset, SV*);
4116                 }
4117                 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4118                 AvMAX(ary) += diff;
4119                 AvFILLp(ary) += diff;
4120             }
4121             else {
4122                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4123                     av_extend(ary, AvFILLp(ary) + diff);
4124                 AvFILLp(ary) += diff;
4125
4126                 if (after) {
4127                     dst = AvARRAY(ary) + AvFILLp(ary);
4128                     src = dst - diff;
4129                     for (i = after; i; i--) {
4130                         *dst-- = *src--;
4131                     }
4132                 }
4133             }
4134         }
4135
4136         if (newlen) {
4137             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4138         }
4139
4140         MARK = ORIGMARK + 1;
4141         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4142             if (length) {
4143                 Copy(tmparyval, MARK, length, SV*);
4144                 if (AvREAL(ary)) {
4145                     EXTEND_MORTAL(length);
4146                     for (i = length, dst = MARK; i; i--) {
4147                         sv_2mortal(*dst);       /* free them eventualy */
4148                         dst++;
4149                     }
4150                 }
4151                 Safefree(tmparyval);
4152             }
4153             MARK += length - 1;
4154         }
4155         else if (length--) {
4156             *MARK = tmparyval[length];
4157             if (AvREAL(ary)) {
4158                 sv_2mortal(*MARK);
4159                 while (length-- > 0)
4160                     SvREFCNT_dec(tmparyval[length]);
4161             }
4162             Safefree(tmparyval);
4163         }
4164         else
4165             *MARK = &PL_sv_undef;
4166     }
4167     SP = MARK;
4168     RETURN;
4169 }
4170
4171 PP(pp_push)
4172 {
4173     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4174     register AV *ary = (AV*)*++MARK;
4175     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4176
4177     if (mg) {
4178         *MARK-- = SvTIED_obj((SV*)ary, mg);
4179         PUSHMARK(MARK);
4180         PUTBACK;
4181         ENTER;
4182         call_method("PUSH",G_SCALAR|G_DISCARD);
4183         LEAVE;
4184         SPAGAIN;
4185         SP = ORIGMARK;
4186         PUSHi( AvFILL(ary) + 1 );
4187     }
4188     else {
4189         for (++MARK; MARK <= SP; MARK++) {
4190             SV * const sv = newSV(0);
4191             if (*MARK)
4192                 sv_setsv(sv, *MARK);
4193             av_store(ary, AvFILLp(ary)+1, sv);
4194         }
4195         SP = ORIGMARK;
4196         PUSHi( AvFILLp(ary) + 1 );
4197     }
4198     RETURN;
4199 }
4200
4201 PP(pp_shift)
4202 {
4203     dVAR;
4204     dSP;
4205     AV * const av = (AV*)POPs;
4206     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4207     EXTEND(SP, 1);
4208     assert (sv);
4209     if (AvREAL(av))
4210         (void)sv_2mortal(sv);
4211     PUSHs(sv);
4212     RETURN;
4213 }
4214
4215 PP(pp_unshift)
4216 {
4217     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4218     register AV *ary = (AV*)*++MARK;
4219     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4220
4221     if (mg) {
4222         *MARK-- = SvTIED_obj((SV*)ary, mg);
4223         PUSHMARK(MARK);
4224         PUTBACK;
4225         ENTER;
4226         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4227         LEAVE;
4228         SPAGAIN;
4229     }
4230     else {
4231         register I32 i = 0;
4232         av_unshift(ary, SP - MARK);
4233         while (MARK < SP) {
4234             SV * const sv = newSVsv(*++MARK);
4235             (void)av_store(ary, i++, sv);
4236         }
4237     }
4238     SP = ORIGMARK;
4239     PUSHi( AvFILL(ary) + 1 );
4240     RETURN;
4241 }
4242
4243 PP(pp_reverse)
4244 {
4245     dVAR; dSP; dMARK;
4246     SV ** const oldsp = SP;
4247
4248     if (GIMME == G_ARRAY) {
4249         MARK++;
4250         while (MARK < SP) {
4251             register SV * const tmp = *MARK;
4252             *MARK++ = *SP;
4253             *SP-- = tmp;
4254         }
4255         /* safe as long as stack cannot get extended in the above */
4256         SP = oldsp;
4257     }
4258     else {
4259         register char *up;
4260         register char *down;
4261         register I32 tmp;
4262         dTARGET;
4263         STRLEN len;
4264         I32 padoff_du;
4265
4266         SvUTF8_off(TARG);                               /* decontaminate */
4267         if (SP - MARK > 1)
4268             do_join(TARG, &PL_sv_no, MARK, SP);
4269         else
4270             sv_setsv(TARG, (SP > MARK)
4271                     ? *SP
4272                     : (padoff_du = find_rundefsvoffset(),
4273                         (padoff_du == NOT_IN_PAD
4274                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4275                         ? DEFSV : PAD_SVl(padoff_du)));
4276         up = SvPV_force(TARG, len);
4277         if (len > 1) {
4278             if (DO_UTF8(TARG)) {        /* first reverse each character */
4279                 U8* s = (U8*)SvPVX(TARG);
4280                 const U8* send = (U8*)(s + len);
4281                 while (s < send) {
4282                     if (UTF8_IS_INVARIANT(*s)) {
4283                         s++;
4284                         continue;
4285                     }
4286                     else {
4287                         if (!utf8_to_uvchr(s, 0))
4288                             break;
4289                         up = (char*)s;
4290                         s += UTF8SKIP(s);
4291                         down = (char*)(s - 1);
4292                         /* reverse this character */
4293                         while (down > up) {
4294                             tmp = *up;
4295                             *up++ = *down;
4296                             *down-- = (char)tmp;
4297                         }
4298                     }
4299                 }
4300                 up = SvPVX(TARG);
4301             }
4302             down = SvPVX(TARG) + len - 1;
4303             while (down > up) {
4304                 tmp = *up;
4305                 *up++ = *down;
4306                 *down-- = (char)tmp;
4307             }
4308             (void)SvPOK_only_UTF8(TARG);
4309         }
4310         SP = MARK + 1;
4311         SETTARG;
4312     }
4313     RETURN;
4314 }
4315
4316 PP(pp_split)
4317 {
4318     dVAR; dSP; dTARG;
4319     AV *ary;
4320     register IV limit = POPi;                   /* note, negative is forever */
4321     SV * const sv = POPs;
4322     STRLEN len;
4323     register const char *s = SvPV_const(sv, len);
4324     const bool do_utf8 = DO_UTF8(sv);
4325     const char *strend = s + len;
4326     register PMOP *pm;
4327     register REGEXP *rx;
4328     register SV *dstr;
4329     register const char *m;
4330     I32 iters = 0;
4331     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4332     I32 maxiters = slen + 10;
4333     const char *orig;
4334     const I32 origlimit = limit;
4335     I32 realarray = 0;
4336     I32 base;
4337     const I32 gimme = GIMME_V;
4338     const I32 oldsave = PL_savestack_ix;
4339     I32 make_mortal = 1;
4340     bool multiline = 0;
4341     MAGIC *mg = NULL;
4342
4343 #ifdef DEBUGGING
4344     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4345 #else
4346     pm = (PMOP*)POPs;
4347 #endif
4348     if (!pm || !s)
4349         DIE(aTHX_ "panic: pp_split");
4350     rx = PM_GETRE(pm);
4351
4352     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4353              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4354
4355     RX_MATCH_UTF8_set(rx, do_utf8);
4356
4357     if (pm->op_pmreplroot) {
4358 #ifdef USE_ITHREADS
4359         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4360 #else
4361         ary = GvAVn((GV*)pm->op_pmreplroot);
4362 #endif
4363     }
4364     else if (gimme != G_ARRAY)
4365         ary = GvAVn(PL_defgv);
4366     else
4367         ary = NULL;
4368     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4369         realarray = 1;
4370         PUTBACK;
4371         av_extend(ary,0);
4372         av_clear(ary);
4373         SPAGAIN;
4374         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4375             PUSHMARK(SP);
4376             XPUSHs(SvTIED_obj((SV*)ary, mg));
4377         }
4378         else {
4379             if (!AvREAL(ary)) {
4380                 I32 i;
4381                 AvREAL_on(ary);
4382                 AvREIFY_off(ary);
4383                 for (i = AvFILLp(ary); i >= 0; i--)
4384                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4385             }
4386             /* temporarily switch stacks */
4387             SAVESWITCHSTACK(PL_curstack, ary);
4388             make_mortal = 0;
4389         }
4390     }
4391     base = SP - PL_stack_base;
4392     orig = s;
4393     if (pm->op_pmflags & PMf_SKIPWHITE) {
4394         if (pm->op_pmflags & PMf_LOCALE) {
4395             while (isSPACE_LC(*s))
4396                 s++;
4397         }
4398         else {
4399             while (isSPACE(*s))
4400                 s++;
4401         }
4402     }
4403     if (pm->op_pmflags & PMf_MULTILINE) {
4404         multiline = 1;
4405     }
4406
4407     if (!limit)
4408         limit = maxiters + 2;
4409     if (pm->op_pmflags & PMf_WHITE) {
4410         while (--limit) {
4411             m = s;
4412             while (m < strend &&
4413                    !((pm->op_pmflags & PMf_LOCALE)
4414                      ? isSPACE_LC(*m) : isSPACE(*m)))
4415                 ++m;
4416             if (m >= strend)
4417                 break;
4418
4419             dstr = newSVpvn(s, m-s);
4420             if (make_mortal)
4421                 sv_2mortal(dstr);
4422             if (do_utf8)
4423                 (void)SvUTF8_on(dstr);
4424             XPUSHs(dstr);
4425
4426             s = m + 1;
4427             while (s < strend &&
4428                    ((pm->op_pmflags & PMf_LOCALE)
4429                     ? isSPACE_LC(*s) : isSPACE(*s)))
4430                 ++s;
4431         }
4432     }
4433     else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4434         while (--limit) {
4435             for (m = s; m < strend && *m != '\n'; m++)
4436                 ;
4437             m++;
4438             if (m >= strend)
4439                 break;
4440             dstr = newSVpvn(s, m-s);
4441             if (make_mortal)
4442                 sv_2mortal(dstr);
4443             if (do_utf8)
4444                 (void)SvUTF8_on(dstr);
4445             XPUSHs(dstr);
4446             s = m;
4447         }
4448     }
4449     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4450              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4451              && (rx->reganch & ROPT_CHECK_ALL)
4452              && !(rx->reganch & ROPT_ANCH)) {
4453         const int tail = (rx->reganch & RE_INTUIT_TAIL);
4454         SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4455
4456         len = rx->minlen;
4457         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4458             const char c = *SvPV_nolen_const(csv);
4459             while (--limit) {
4460                 for (m = s; m < strend && *m != c; m++)
4461                     ;
4462                 if (m >= strend)
4463                     break;
4464                 dstr = newSVpvn(s, m-s);
4465                 if (make_mortal)
4466                     sv_2mortal(dstr);
4467                 if (do_utf8)
4468                     (void)SvUTF8_on(dstr);
4469                 XPUSHs(dstr);
4470                 /* The rx->minlen is in characters but we want to step
4471                  * s ahead by bytes. */
4472                 if (do_utf8)
4473                     s = (char*)utf8_hop((U8*)m, len);
4474                 else
4475                     s = m + len; /* Fake \n at the end */
4476             }
4477         }
4478         else {
4479             while (s < strend && --limit &&
4480               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4481                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4482             {
4483                 dstr = newSVpvn(s, m-s);
4484                 if (make_mortal)
4485                     sv_2mortal(dstr);
4486                 if (do_utf8)
4487                     (void)SvUTF8_on(dstr);
4488                 XPUSHs(dstr);
4489                 /* The rx->minlen is in characters but we want to step
4490                  * s ahead by bytes. */
4491                 if (do_utf8)
4492                     s = (char*)utf8_hop((U8*)m, len);
4493                 else
4494                     s = m + len; /* Fake \n at the end */
4495             }
4496         }
4497     }
4498     else {
4499         maxiters += slen * rx->nparens;
4500         while (s < strend && --limit)
4501         {
4502             I32 rex_return;
4503             PUTBACK;
4504             rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4505                             sv, NULL, 0);
4506             SPAGAIN;
4507             if (rex_return == 0)
4508                 break;
4509             TAINT_IF(RX_MATCH_TAINTED(rx));
4510             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4511                 m = s;
4512                 s = orig;
4513                 orig = rx->subbeg;
4514                 s = orig + (m - s);
4515                 strend = s + (strend - m);
4516             }
4517             m = rx->startp[0] + orig;
4518             dstr = newSVpvn(s, m-s);
4519             if (make_mortal)
4520                 sv_2mortal(dstr);
4521             if (do_utf8)
4522                 (void)SvUTF8_on(dstr);
4523             XPUSHs(dstr);
4524             if (rx->nparens) {
4525                 I32 i;
4526                 for (i = 1; i <= (I32)rx->nparens; i++) {
4527                     s = rx->startp[i] + orig;
4528                     m = rx->endp[i] + orig;
4529
4530                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4531                        parens that didn't match -- they should be set to
4532                        undef, not the empty string */
4533                     if (m >= orig && s >= orig) {
4534                         dstr = newSVpvn(s, m-s);
4535                     }
4536                     else
4537                         dstr = &PL_sv_undef;  /* undef, not "" */
4538                     if (make_mortal)
4539                         sv_2mortal(dstr);
4540                     if (do_utf8)
4541                         (void)SvUTF8_on(dstr);
4542                     XPUSHs(dstr);
4543                 }
4544             }
4545             s = rx->endp[0] + orig;
4546         }
4547     }
4548
4549     iters = (SP - PL_stack_base) - base;
4550     if (iters > maxiters)
4551         DIE(aTHX_ "Split loop");
4552
4553     /* keep field after final delim? */
4554     if (s < strend || (iters && origlimit)) {
4555         const STRLEN l = strend - s;
4556         dstr = newSVpvn(s, l);
4557         if (make_mortal)
4558             sv_2mortal(dstr);
4559         if (do_utf8)
4560             (void)SvUTF8_on(dstr);
4561         XPUSHs(dstr);
4562         iters++;
4563     }
4564     else if (!origlimit) {
4565         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4566             if (TOPs && !make_mortal)
4567                 sv_2mortal(TOPs);
4568             iters--;
4569             *SP-- = &PL_sv_undef;
4570         }
4571     }
4572
4573     PUTBACK;
4574     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4575     SPAGAIN;
4576     if (realarray) {
4577         if (!mg) {
4578             if (SvSMAGICAL(ary)) {
4579                 PUTBACK;
4580                 mg_set((SV*)ary);
4581                 SPAGAIN;
4582             }
4583             if (gimme == G_ARRAY) {
4584                 EXTEND(SP, iters);
4585                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4586                 SP += iters;
4587                 RETURN;
4588             }
4589         }
4590         else {
4591             PUTBACK;
4592             ENTER;
4593             call_method("PUSH",G_SCALAR|G_DISCARD);
4594             LEAVE;
4595             SPAGAIN;
4596             if (gimme == G_ARRAY) {
4597                 I32 i;
4598                 /* EXTEND should not be needed - we just popped them */
4599                 EXTEND(SP, iters);
4600                 for (i=0; i < iters; i++) {
4601                     SV **svp = av_fetch(ary, i, FALSE);
4602                     PUSHs((svp) ? *svp : &PL_sv_undef);
4603                 }
4604                 RETURN;
4605             }
4606         }
4607     }
4608     else {
4609         if (gimme == G_ARRAY)
4610             RETURN;
4611     }
4612
4613     GETTARGET;
4614     PUSHi(iters);
4615     RETURN;
4616 }
4617
4618 PP(pp_lock)
4619 {
4620     dVAR;
4621     dSP;
4622     dTOPss;
4623     SV *retsv = sv;
4624     SvLOCK(sv);
4625     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4626         || SvTYPE(retsv) == SVt_PVCV) {
4627         retsv = refto(retsv);
4628     }
4629     SETs(retsv);
4630     RETURN;
4631 }
4632
4633
4634 PP(unimplemented_op)
4635 {
4636     dVAR;
4637     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4638         PL_op->op_type);
4639 }
4640
4641 /*
4642  * Local variables:
4643  * c-indentation-style: bsd
4644  * c-basic-offset: 4
4645  * indent-tabs-mode: t
4646  * End:
4647  *
4648  * ex: set ts=8 sts=4 sw=4 noet:
4649  */