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