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