pp.c

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