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     if (SvTAINTED(MARK[1]))
3314         TAINT_PROPER("sprintf");
3315     do_sprintf(TARG, SP-MARK, MARK+1);
3316     TAINT_IF(SvTAINTED(TARG));
3317     SP = ORIGMARK;
3318     PUSHTARG;
3319     RETURN;
3320 }
3321
3322 PP(pp_ord)
3323 {
3324     dVAR; dSP; dTARGET;
3325
3326     SV *argsv = POPs;
3327     STRLEN len;
3328     const U8 *s = (U8*)SvPV_const(argsv, len);
3329
3330     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3331         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3332         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3333         argsv = tmpsv;
3334     }
3335
3336     XPUSHu(DO_UTF8(argsv) ?
3337            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3338            (*s & 0xff));
3339
3340     RETURN;
3341 }
3342
3343 PP(pp_chr)
3344 {
3345     dVAR; dSP; dTARGET;
3346     char *tmps;
3347     UV value;
3348
3349     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3350          ||
3351          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3352         if (IN_BYTES) {
3353             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3354         } else {
3355             (void) POPs; /* Ignore the argument value. */
3356             value = UNICODE_REPLACEMENT;
3357         }
3358     } else {
3359         value = POPu;
3360     }
3361
3362     SvUPGRADE(TARG,SVt_PV);
3363
3364     if (value > 255 && !IN_BYTES) {
3365         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3366         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3367         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3368         *tmps = '\0';
3369         (void)SvPOK_only(TARG);
3370         SvUTF8_on(TARG);
3371         XPUSHs(TARG);
3372         RETURN;
3373     }
3374
3375     SvGROW(TARG,2);
3376     SvCUR_set(TARG, 1);
3377     tmps = SvPVX(TARG);
3378     *tmps++ = (char)value;
3379     *tmps = '\0';
3380     (void)SvPOK_only(TARG);
3381
3382     if (PL_encoding && !IN_BYTES) {
3383         sv_recode_to_utf8(TARG, PL_encoding);
3384         tmps = SvPVX(TARG);
3385         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3386             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3387             SvGROW(TARG, 2);
3388             tmps = SvPVX(TARG);
3389             SvCUR_set(TARG, 1);
3390             *tmps++ = (char)value;
3391             *tmps = '\0';
3392             SvUTF8_off(TARG);
3393         }
3394     }
3395
3396     XPUSHs(TARG);
3397     RETURN;
3398 }
3399
3400 PP(pp_crypt)
3401 {
3402 #ifdef HAS_CRYPT
3403     dVAR; dSP; dTARGET;
3404     dPOPTOPssrl;
3405     STRLEN len;
3406     const char *tmps = SvPV_const(left, len);
3407
3408     if (DO_UTF8(left)) {
3409          /* If Unicode, try to downgrade.
3410           * If not possible, croak.
3411           * Yes, we made this up.  */
3412          SV* const tsv = sv_2mortal(newSVsv(left));
3413
3414          SvUTF8_on(tsv);
3415          sv_utf8_downgrade(tsv, FALSE);
3416          tmps = SvPV_const(tsv, len);
3417     }
3418 #   ifdef USE_ITHREADS
3419 #     ifdef HAS_CRYPT_R
3420     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3421       /* This should be threadsafe because in ithreads there is only
3422        * one thread per interpreter.  If this would not be true,
3423        * we would need a mutex to protect this malloc. */
3424         PL_reentrant_buffer->_crypt_struct_buffer =
3425           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3426 #if defined(__GLIBC__) || defined(__EMX__)
3427         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3428             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3429             /* work around glibc-2.2.5 bug */
3430             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3431         }
3432 #endif
3433     }
3434 #     endif /* HAS_CRYPT_R */
3435 #   endif /* USE_ITHREADS */
3436 #   ifdef FCRYPT
3437     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3438 #   else
3439     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3440 #   endif
3441     SETs(TARG);
3442     RETURN;
3443 #else
3444     DIE(aTHX_
3445       "The crypt() function is unimplemented due to excessive paranoia.");
3446 #endif
3447 }
3448
3449 PP(pp_ucfirst)
3450 {
3451     dVAR;
3452     dSP;
3453     SV *source = TOPs;
3454     STRLEN slen;
3455     STRLEN need;
3456     SV *dest;
3457     bool inplace = TRUE;
3458     bool doing_utf8;
3459     const int op_type = PL_op->op_type;
3460     const U8 *s;
3461     U8 *d;
3462     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3463     STRLEN ulen;
3464     STRLEN tculen;
3465
3466     SvGETMAGIC(source);
3467     if (SvOK(source)) {
3468         s = (const U8*)SvPV_nomg_const(source, slen);
3469     } else {
3470         s = (const U8*)"";
3471         slen = 0;
3472     }
3473
3474     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3475         doing_utf8 = TRUE;
3476         utf8_to_uvchr(s, &ulen);
3477         if (op_type == OP_UCFIRST) {
3478             toTITLE_utf8(s, tmpbuf, &tculen);
3479         } else {
3480             toLOWER_utf8(s, tmpbuf, &tculen);
3481         }
3482         /* If the two differ, we definately cannot do inplace.  */
3483         inplace = (ulen == tculen);
3484         need = slen + 1 - ulen + tculen;
3485     } else {
3486         doing_utf8 = FALSE;
3487         need = slen + 1;
3488     }
3489
3490     if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3491         /* We can convert in place.  */
3492
3493         dest = source;
3494         s = d = (U8*)SvPV_force_nomg(source, slen);
3495     } else {
3496         dTARGET;
3497
3498         dest = TARG;
3499
3500         SvUPGRADE(dest, SVt_PV);
3501         d = (U8*)SvGROW(dest, need);
3502         (void)SvPOK_only(dest);
3503
3504         SETs(dest);
3505
3506         inplace = FALSE;
3507     }
3508
3509     if (doing_utf8) {
3510         if(!inplace) {
3511             /* slen is the byte length of the whole SV.
3512              * ulen is the byte length of the original Unicode character
3513              * stored as UTF-8 at s.
3514              * tculen is the byte length of the freshly titlecased (or
3515              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3516              * We first set the result to be the titlecased (/lowercased)
3517              * character, and then append the rest of the SV data. */
3518             sv_setpvn(dest, (char*)tmpbuf, tculen);
3519             if (slen > ulen)
3520                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3521             SvUTF8_on(dest);
3522         }
3523         else {
3524             Copy(tmpbuf, d, tculen, U8);
3525             SvCUR_set(dest, need - 1);
3526         }
3527     }
3528     else {
3529         if (*s) {
3530             if (IN_LOCALE_RUNTIME) {
3531                 TAINT;
3532                 SvTAINTED_on(dest);
3533                 *d = (op_type == OP_UCFIRST)
3534                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3535             }
3536             else
3537                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3538         } else {
3539             /* See bug #39028  */
3540             *d = *s;
3541         }
3542
3543         if (SvUTF8(source))
3544             SvUTF8_on(dest);
3545
3546         if (!inplace) {
3547             /* This will copy the trailing NUL  */
3548             Copy(s + 1, d + 1, slen, U8);
3549             SvCUR_set(dest, need - 1);
3550         }
3551     }
3552     SvSETMAGIC(dest);
3553     RETURN;
3554 }
3555
3556 /* There's so much setup/teardown code common between uc and lc, I wonder if
3557    it would be worth merging the two, and just having a switch outside each
3558    of the three tight loops.  */
3559 PP(pp_uc)
3560 {
3561     dVAR;
3562     dSP;
3563     SV *source = TOPs;
3564     STRLEN len;
3565     STRLEN min;
3566     SV *dest;
3567     const U8 *s;
3568     U8 *d;
3569
3570     SvGETMAGIC(source);
3571
3572     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3573         && !DO_UTF8(source)) {
3574         /* We can convert in place.  */
3575
3576         dest = source;
3577         s = d = (U8*)SvPV_force_nomg(source, len);
3578         min = len + 1;
3579     } else {
3580         dTARGET;
3581
3582         dest = TARG;
3583
3584         /* The old implementation would copy source into TARG at this point.
3585            This had the side effect that if source was undef, TARG was now
3586            an undefined SV with PADTMP set, and they don't warn inside
3587            sv_2pv_flags(). However, we're now getting the PV direct from
3588            source, which doesn't have PADTMP set, so it would warn. Hence the
3589            little games.  */
3590
3591         if (SvOK(source)) {
3592             s = (const U8*)SvPV_nomg_const(source, len);
3593         } else {
3594             s = (const U8*)"";
3595             len = 0;
3596         }
3597         min = len + 1;
3598
3599         SvUPGRADE(dest, SVt_PV);
3600         d = (U8*)SvGROW(dest, min);
3601         (void)SvPOK_only(dest);
3602
3603         SETs(dest);
3604     }
3605
3606     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3607        to check DO_UTF8 again here.  */
3608
3609     if (DO_UTF8(source)) {
3610         const U8 *const send = s + len;
3611         U8 tmpbuf[UTF8_MAXBYTES+1];
3612
3613         while (s < send) {
3614             const STRLEN u = UTF8SKIP(s);
3615             STRLEN ulen;
3616
3617             toUPPER_utf8(s, tmpbuf, &ulen);
3618             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3619                 /* If the eventually required minimum size outgrows
3620                  * the available space, we need to grow. */
3621                 const UV o = d - (U8*)SvPVX_const(dest);
3622
3623                 /* If someone uppercases one million U+03B0s we SvGROW() one
3624                  * million times.  Or we could try guessing how much to
3625                  allocate without allocating too much.  Such is life. */
3626                 SvGROW(dest, min);
3627                 d = (U8*)SvPVX(dest) + o;
3628             }
3629             Copy(tmpbuf, d, ulen, U8);
3630             d += ulen;
3631             s += u;
3632         }
3633         SvUTF8_on(dest);
3634         *d = '\0';
3635         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3636     } else {
3637         if (len) {
3638             const U8 *const send = s + len;
3639             if (IN_LOCALE_RUNTIME) {
3640                 TAINT;
3641                 SvTAINTED_on(dest);
3642                 for (; s < send; d++, s++)
3643                     *d = toUPPER_LC(*s);
3644             }
3645             else {
3646                 for (; s < send; d++, s++)
3647                     *d = toUPPER(*s);
3648             }
3649         }
3650         if (source != dest) {
3651             *d = '\0';
3652             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3653         }
3654     }
3655     SvSETMAGIC(dest);
3656     RETURN;
3657 }
3658
3659 PP(pp_lc)
3660 {
3661     dVAR;
3662     dSP;
3663     SV *source = TOPs;
3664     STRLEN len;
3665     STRLEN min;
3666     SV *dest;
3667     const U8 *s;
3668     U8 *d;
3669
3670     SvGETMAGIC(source);
3671
3672     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3673         && !DO_UTF8(source)) {
3674         /* We can convert in place.  */
3675
3676         dest = source;
3677         s = d = (U8*)SvPV_force_nomg(source, len);
3678         min = len + 1;
3679     } else {
3680         dTARGET;
3681
3682         dest = TARG;
3683
3684         /* The old implementation would copy source into TARG at this point.
3685            This had the side effect that if source was undef, TARG was now
3686            an undefined SV with PADTMP set, and they don't warn inside
3687            sv_2pv_flags(). However, we're now getting the PV direct from
3688            source, which doesn't have PADTMP set, so it would warn. Hence the
3689            little games.  */
3690
3691         if (SvOK(source)) {
3692             s = (const U8*)SvPV_nomg_const(source, len);
3693         } else {
3694             s = (const U8*)"";
3695             len = 0;
3696         }
3697         min = len + 1;
3698
3699         SvUPGRADE(dest, SVt_PV);
3700         d = (U8*)SvGROW(dest, min);
3701         (void)SvPOK_only(dest);
3702
3703         SETs(dest);
3704     }
3705
3706     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3707        to check DO_UTF8 again here.  */
3708
3709     if (DO_UTF8(source)) {
3710         const U8 *const send = s + len;
3711         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3712
3713         while (s < send) {
3714             const STRLEN u = UTF8SKIP(s);
3715             STRLEN ulen;
3716             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3717
3718 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3719             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3720                 NOOP;
3721                 /*
3722                  * Now if the sigma is NOT followed by
3723                  * /$ignorable_sequence$cased_letter/;
3724                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3725                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3726                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3727                  * then it should be mapped to 0x03C2,
3728                  * (GREEK SMALL LETTER FINAL SIGMA),
3729                  * instead of staying 0x03A3.
3730                  * "should be": in other words, this is not implemented yet.
3731                  * See lib/unicore/SpecialCasing.txt.
3732                  */
3733             }
3734             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3735                 /* If the eventually required minimum size outgrows
3736                  * the available space, we need to grow. */
3737                 const UV o = d - (U8*)SvPVX_const(dest);
3738
3739                 /* If someone lowercases one million U+0130s we SvGROW() one
3740                  * million times.  Or we could try guessing how much to
3741                  allocate without allocating too much.  Such is life. */
3742                 SvGROW(dest, min);
3743                 d = (U8*)SvPVX(dest) + o;
3744             }
3745             Copy(tmpbuf, d, ulen, U8);
3746             d += ulen;
3747             s += u;
3748         }
3749         SvUTF8_on(dest);
3750         *d = '\0';
3751         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3752     } else {
3753         if (len) {
3754             const U8 *const send = s + len;
3755             if (IN_LOCALE_RUNTIME) {
3756                 TAINT;
3757                 SvTAINTED_on(dest);
3758                 for (; s < send; d++, s++)
3759                     *d = toLOWER_LC(*s);
3760             }
3761             else {
3762                 for (; s < send; d++, s++)
3763                     *d = toLOWER(*s);
3764             }
3765         }
3766         if (source != dest) {
3767             *d = '\0';
3768             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3769         }
3770     }
3771     SvSETMAGIC(dest);
3772     RETURN;
3773 }
3774
3775 PP(pp_quotemeta)
3776 {
3777     dVAR; dSP; dTARGET;
3778     SV * const sv = TOPs;
3779     STRLEN len;
3780     register const char *s = SvPV_const(sv,len);
3781
3782     SvUTF8_off(TARG);                           /* decontaminate */
3783     if (len) {
3784         register char *d;
3785         SvUPGRADE(TARG, SVt_PV);
3786         SvGROW(TARG, (len * 2) + 1);
3787         d = SvPVX(TARG);
3788         if (DO_UTF8(sv)) {
3789             while (len) {
3790                 if (UTF8_IS_CONTINUED(*s)) {
3791                     STRLEN ulen = UTF8SKIP(s);
3792                     if (ulen > len)
3793                         ulen = len;
3794                     len -= ulen;
3795                     while (ulen--)
3796                         *d++ = *s++;
3797                 }
3798                 else {
3799                     if (!isALNUM(*s))
3800                         *d++ = '\\';
3801                     *d++ = *s++;
3802                     len--;
3803                 }
3804             }
3805             SvUTF8_on(TARG);
3806         }
3807         else {
3808             while (len--) {
3809                 if (!isALNUM(*s))
3810                     *d++ = '\\';
3811                 *d++ = *s++;
3812             }
3813         }
3814         *d = '\0';
3815         SvCUR_set(TARG, d - SvPVX_const(TARG));
3816         (void)SvPOK_only_UTF8(TARG);
3817     }
3818     else
3819         sv_setpvn(TARG, s, len);
3820     SETs(TARG);
3821     if (SvSMAGICAL(TARG))
3822         mg_set(TARG);
3823     RETURN;
3824 }
3825
3826 /* Arrays. */
3827
3828 PP(pp_aslice)
3829 {
3830     dVAR; dSP; dMARK; dORIGMARK;
3831     register AV* const av = (AV*)POPs;
3832     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3833
3834     if (SvTYPE(av) == SVt_PVAV) {
3835         const I32 arybase = CopARYBASE_get(PL_curcop);
3836         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3837             register SV **svp;
3838             I32 max = -1;
3839             for (svp = MARK + 1; svp <= SP; svp++) {
3840                 const I32 elem = SvIVx(*svp);
3841                 if (elem > max)
3842                     max = elem;
3843             }
3844             if (max > AvMAX(av))
3845                 av_extend(av, max);
3846         }
3847         while (++MARK <= SP) {
3848             register SV **svp;
3849             I32 elem = SvIVx(*MARK);
3850
3851             if (elem > 0)
3852                 elem -= arybase;
3853             svp = av_fetch(av, elem, lval);
3854             if (lval) {
3855                 if (!svp || *svp == &PL_sv_undef)
3856                     DIE(aTHX_ PL_no_aelem, elem);
3857                 if (PL_op->op_private & OPpLVAL_INTRO)
3858                     save_aelem(av, elem, svp);
3859             }
3860             *MARK = svp ? *svp : &PL_sv_undef;
3861         }
3862     }
3863     if (GIMME != G_ARRAY) {
3864         MARK = ORIGMARK;
3865         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3866         SP = MARK;
3867     }
3868     RETURN;
3869 }
3870
3871 /* Associative arrays. */
3872
3873 PP(pp_each)
3874 {
3875     dVAR;
3876     dSP;
3877     HV * hash = (HV*)POPs;
3878     HE *entry;
3879     const I32 gimme = GIMME_V;
3880
3881     PUTBACK;
3882     /* might clobber stack_sp */
3883     entry = hv_iternext(hash);
3884     SPAGAIN;
3885
3886     EXTEND(SP, 2);
3887     if (entry) {
3888         SV* const sv = hv_iterkeysv(entry);
3889         PUSHs(sv);      /* won't clobber stack_sp */
3890         if (gimme == G_ARRAY) {
3891             SV *val;
3892             PUTBACK;
3893             /* might clobber stack_sp */
3894             val = hv_iterval(hash, entry);
3895             SPAGAIN;
3896             PUSHs(val);
3897         }
3898     }
3899     else if (gimme == G_SCALAR)
3900         RETPUSHUNDEF;
3901
3902     RETURN;
3903 }
3904
3905 PP(pp_delete)
3906 {
3907     dVAR;
3908     dSP;
3909     const I32 gimme = GIMME_V;
3910     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3911
3912     if (PL_op->op_private & OPpSLICE) {
3913         dMARK; dORIGMARK;
3914         HV * const hv = (HV*)POPs;
3915         const U32 hvtype = SvTYPE(hv);
3916         if (hvtype == SVt_PVHV) {                       /* hash element */
3917             while (++MARK <= SP) {
3918                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3919                 *MARK = sv ? sv : &PL_sv_undef;
3920             }
3921         }
3922         else if (hvtype == SVt_PVAV) {                  /* array element */
3923             if (PL_op->op_flags & OPf_SPECIAL) {
3924                 while (++MARK <= SP) {
3925                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3926                     *MARK = sv ? sv : &PL_sv_undef;
3927                 }
3928             }
3929         }
3930         else
3931             DIE(aTHX_ "Not a HASH reference");
3932         if (discard)
3933             SP = ORIGMARK;
3934         else if (gimme == G_SCALAR) {
3935             MARK = ORIGMARK;
3936             if (SP > MARK)
3937                 *++MARK = *SP;
3938             else
3939                 *++MARK = &PL_sv_undef;
3940             SP = MARK;
3941         }
3942     }
3943     else {
3944         SV *keysv = POPs;
3945         HV * const hv = (HV*)POPs;
3946         SV *sv;
3947         if (SvTYPE(hv) == SVt_PVHV)
3948             sv = hv_delete_ent(hv, keysv, discard, 0);
3949         else if (SvTYPE(hv) == SVt_PVAV) {
3950             if (PL_op->op_flags & OPf_SPECIAL)
3951                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3952             else
3953                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3954         }
3955         else
3956             DIE(aTHX_ "Not a HASH reference");
3957         if (!sv)
3958             sv = &PL_sv_undef;
3959         if (!discard)
3960             PUSHs(sv);
3961     }
3962     RETURN;
3963 }
3964
3965 PP(pp_exists)
3966 {
3967     dVAR;
3968     dSP;
3969     SV *tmpsv;
3970     HV *hv;
3971
3972     if (PL_op->op_private & OPpEXISTS_SUB) {
3973         GV *gv;
3974         SV * const sv = POPs;
3975         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3976         if (cv)
3977             RETPUSHYES;
3978         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3979             RETPUSHYES;
3980         RETPUSHNO;
3981     }
3982     tmpsv = POPs;
3983     hv = (HV*)POPs;
3984     if (SvTYPE(hv) == SVt_PVHV) {
3985         if (hv_exists_ent(hv, tmpsv, 0))
3986             RETPUSHYES;
3987     }
3988     else if (SvTYPE(hv) == SVt_PVAV) {
3989         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3990             if (av_exists((AV*)hv, SvIV(tmpsv)))
3991                 RETPUSHYES;
3992         }
3993     }
3994     else {
3995         DIE(aTHX_ "Not a HASH reference");
3996     }
3997     RETPUSHNO;
3998 }
3999
4000 PP(pp_hslice)
4001 {
4002     dVAR; dSP; dMARK; dORIGMARK;
4003     register HV * const hv = (HV*)POPs;
4004     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4005     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4006     bool other_magic = FALSE;
4007
4008     if (localizing) {
4009         MAGIC *mg;
4010         HV *stash;
4011
4012         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4013             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4014              /* Try to preserve the existenceness of a tied hash
4015               * element by using EXISTS and DELETE if possible.
4016               * Fallback to FETCH and STORE otherwise */
4017              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4018              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4019              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4020     }
4021
4022     while (++MARK <= SP) {
4023         SV * const keysv = *MARK;
4024         SV **svp;
4025         HE *he;
4026         bool preeminent = FALSE;
4027
4028         if (localizing) {
4029             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4030                 hv_exists_ent(hv, keysv, 0);
4031         }
4032
4033         he = hv_fetch_ent(hv, keysv, lval, 0);
4034         svp = he ? &HeVAL(he) : 0;
4035
4036         if (lval) {
4037             if (!svp || *svp == &PL_sv_undef) {
4038                 DIE(aTHX_ PL_no_helem_sv, keysv);
4039             }
4040             if (localizing) {
4041                 if (HvNAME_get(hv) && isGV(*svp))
4042                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4043                 else {
4044                     if (preeminent)
4045                         save_helem(hv, keysv, svp);
4046                     else {
4047                         STRLEN keylen;
4048                         const char * const key = SvPV_const(keysv, keylen);
4049                         SAVEDELETE(hv, savepvn(key,keylen),
4050                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4051                     }
4052                 }
4053             }
4054         }
4055         *MARK = svp ? *svp : &PL_sv_undef;
4056     }
4057     if (GIMME != G_ARRAY) {
4058         MARK = ORIGMARK;
4059         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4060         SP = MARK;
4061     }
4062     RETURN;
4063 }
4064
4065 /* List operators. */
4066
4067 PP(pp_list)
4068 {
4069     dVAR; dSP; dMARK;
4070     if (GIMME != G_ARRAY) {
4071         if (++MARK <= SP)
4072             *MARK = *SP;                /* unwanted list, return last item */
4073         else
4074             *MARK = &PL_sv_undef;
4075         SP = MARK;
4076     }
4077     RETURN;
4078 }
4079
4080 PP(pp_lslice)
4081 {
4082     dVAR;
4083     dSP;
4084     SV ** const lastrelem = PL_stack_sp;
4085     SV ** const lastlelem = PL_stack_base + POPMARK;
4086     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4087     register SV ** const firstrelem = lastlelem + 1;
4088     const I32 arybase = CopARYBASE_get(PL_curcop);
4089     I32 is_something_there = FALSE;
4090
4091     register const I32 max = lastrelem - lastlelem;
4092     register SV **lelem;
4093
4094     if (GIMME != G_ARRAY) {
4095         I32 ix = SvIVx(*lastlelem);
4096         if (ix < 0)
4097             ix += max;
4098         else
4099             ix -= arybase;
4100         if (ix < 0 || ix >= max)
4101             *firstlelem = &PL_sv_undef;
4102         else
4103             *firstlelem = firstrelem[ix];
4104         SP = firstlelem;
4105         RETURN;
4106     }
4107
4108     if (max == 0) {
4109         SP = firstlelem - 1;
4110         RETURN;
4111     }
4112
4113     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4114         I32 ix = SvIVx(*lelem);
4115         if (ix < 0)
4116             ix += max;
4117         else
4118             ix -= arybase;
4119         if (ix < 0 || ix >= max)
4120             *lelem = &PL_sv_undef;
4121         else {
4122             is_something_there = TRUE;
4123             if (!(*lelem = firstrelem[ix]))
4124                 *lelem = &PL_sv_undef;
4125         }
4126     }
4127     if (is_something_there)
4128         SP = lastlelem;
4129     else
4130         SP = firstlelem - 1;
4131     RETURN;
4132 }
4133
4134 PP(pp_anonlist)
4135 {
4136     dVAR; dSP; dMARK; dORIGMARK;
4137     const I32 items = SP - MARK;
4138     SV * const av = (SV *) av_make(items, MARK+1);
4139     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4140     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4141                       ? newRV_noinc(av) : av));
4142     RETURN;
4143 }
4144
4145 PP(pp_anonhash)
4146 {
4147     dVAR; dSP; dMARK; dORIGMARK;
4148     HV* const hv = newHV();
4149
4150     while (MARK < SP) {
4151         SV * const key = *++MARK;
4152         SV * const val = newSV(0);
4153         if (MARK < SP)
4154             sv_setsv(val, *++MARK);
4155         else if (ckWARN(WARN_MISC))
4156             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4157         (void)hv_store_ent(hv,key,val,0);
4158     }
4159     SP = ORIGMARK;
4160     XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4161                       ? newRV_noinc((SV*) hv) : (SV*)hv));
4162     RETURN;
4163 }
4164
4165 PP(pp_splice)
4166 {
4167     dVAR; dSP; dMARK; dORIGMARK;
4168     register AV *ary = (AV*)*++MARK;
4169     register SV **src;
4170     register SV **dst;
4171     register I32 i;
4172     register I32 offset;
4173     register I32 length;
4174     I32 newlen;
4175     I32 after;
4176     I32 diff;
4177     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4178
4179     if (mg) {
4180         *MARK-- = SvTIED_obj((SV*)ary, mg);
4181         PUSHMARK(MARK);
4182         PUTBACK;
4183         ENTER;
4184         call_method("SPLICE",GIMME_V);
4185         LEAVE;
4186         SPAGAIN;
4187         RETURN;
4188     }
4189
4190     SP++;
4191
4192     if (++MARK < SP) {
4193         offset = i = SvIVx(*MARK);
4194         if (offset < 0)
4195             offset += AvFILLp(ary) + 1;
4196         else
4197             offset -= CopARYBASE_get(PL_curcop);
4198         if (offset < 0)
4199             DIE(aTHX_ PL_no_aelem, i);
4200         if (++MARK < SP) {
4201             length = SvIVx(*MARK++);
4202             if (length < 0) {
4203                 length += AvFILLp(ary) - offset + 1;
4204                 if (length < 0)
4205                     length = 0;
4206             }
4207         }
4208         else
4209             length = AvMAX(ary) + 1;            /* close enough to infinity */
4210     }
4211     else {
4212         offset = 0;
4213         length = AvMAX(ary) + 1;
4214     }
4215     if (offset > AvFILLp(ary) + 1) {
4216         if (ckWARN(WARN_MISC))
4217             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4218         offset = AvFILLp(ary) + 1;
4219     }
4220     after = AvFILLp(ary) + 1 - (offset + length);
4221     if (after < 0) {                            /* not that much array */
4222         length += after;                        /* offset+length now in array */
4223         after = 0;
4224         if (!AvALLOC(ary))
4225             av_extend(ary, 0);
4226     }
4227
4228     /* At this point, MARK .. SP-1 is our new LIST */
4229
4230     newlen = SP - MARK;
4231     diff = newlen - length;
4232     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4233         av_reify(ary);
4234
4235     /* make new elements SVs now: avoid problems if they're from the array */
4236     for (dst = MARK, i = newlen; i; i--) {
4237         SV * const h = *dst;
4238         *dst++ = newSVsv(h);
4239     }
4240
4241     if (diff < 0) {                             /* shrinking the area */
4242         SV **tmparyval = NULL;
4243         if (newlen) {
4244             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4245             Copy(MARK, tmparyval, newlen, SV*);
4246         }
4247
4248         MARK = ORIGMARK + 1;
4249         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4250             MEXTEND(MARK, length);
4251             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4252             if (AvREAL(ary)) {
4253                 EXTEND_MORTAL(length);
4254                 for (i = length, dst = MARK; i; i--) {
4255                     sv_2mortal(*dst);   /* free them eventualy */
4256                     dst++;
4257                 }
4258             }
4259             MARK += length - 1;
4260         }
4261         else {
4262             *MARK = AvARRAY(ary)[offset+length-1];
4263             if (AvREAL(ary)) {
4264                 sv_2mortal(*MARK);
4265                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4266                     SvREFCNT_dec(*dst++);       /* free them now */
4267             }
4268         }
4269         AvFILLp(ary) += diff;
4270
4271         /* pull up or down? */
4272
4273         if (offset < after) {                   /* easier to pull up */
4274             if (offset) {                       /* esp. if nothing to pull */
4275                 src = &AvARRAY(ary)[offset-1];
4276                 dst = src - diff;               /* diff is negative */
4277                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4278                     *dst-- = *src--;
4279             }
4280             dst = AvARRAY(ary);
4281             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4282             AvMAX(ary) += diff;
4283         }
4284         else {
4285             if (after) {                        /* anything to pull down? */
4286                 src = AvARRAY(ary) + offset + length;
4287                 dst = src + diff;               /* diff is negative */
4288                 Move(src, dst, after, SV*);
4289             }
4290             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4291                                                 /* avoid later double free */
4292         }
4293         i = -diff;
4294         while (i)
4295             dst[--i] = &PL_sv_undef;
4296
4297         if (newlen) {
4298             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4299             Safefree(tmparyval);
4300         }
4301     }
4302     else {                                      /* no, expanding (or same) */
4303         SV** tmparyval = NULL;
4304         if (length) {
4305             Newx(tmparyval, length, SV*);       /* so remember deletion */
4306             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4307         }
4308
4309         if (diff > 0) {                         /* expanding */
4310             /* push up or down? */
4311             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4312                 if (offset) {
4313                     src = AvARRAY(ary);
4314                     dst = src - diff;
4315                     Move(src, dst, offset, SV*);
4316                 }
4317                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4318                 AvMAX(ary) += diff;
4319                 AvFILLp(ary) += diff;
4320             }
4321             else {
4322                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4323                     av_extend(ary, AvFILLp(ary) + diff);
4324                 AvFILLp(ary) += diff;
4325
4326                 if (after) {
4327                     dst = AvARRAY(ary) + AvFILLp(ary);
4328                     src = dst - diff;
4329                     for (i = after; i; i--) {
4330                         *dst-- = *src--;
4331                     }
4332                 }
4333             }
4334         }
4335
4336         if (newlen) {
4337             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4338         }
4339
4340         MARK = ORIGMARK + 1;
4341         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4342             if (length) {
4343                 Copy(tmparyval, MARK, length, SV*);
4344                 if (AvREAL(ary)) {
4345                     EXTEND_MORTAL(length);
4346                     for (i = length, dst = MARK; i; i--) {
4347                         sv_2mortal(*dst);       /* free them eventualy */
4348                         dst++;
4349                     }
4350                 }
4351             }
4352             MARK += length - 1;
4353         }
4354         else if (length--) {
4355             *MARK = tmparyval[length];
4356             if (AvREAL(ary)) {
4357                 sv_2mortal(*MARK);
4358                 while (length-- > 0)
4359                     SvREFCNT_dec(tmparyval[length]);
4360             }
4361         }
4362         else
4363             *MARK = &PL_sv_undef;
4364         Safefree(tmparyval);
4365     }
4366     SP = MARK;
4367     RETURN;
4368 }
4369
4370 PP(pp_push)
4371 {
4372     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4373     register AV * const ary = (AV*)*++MARK;
4374     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4375
4376     if (mg) {
4377         *MARK-- = SvTIED_obj((SV*)ary, mg);
4378         PUSHMARK(MARK);
4379         PUTBACK;
4380         ENTER;
4381         call_method("PUSH",G_SCALAR|G_DISCARD);
4382         LEAVE;
4383         SPAGAIN;
4384         SP = ORIGMARK;
4385         PUSHi( AvFILL(ary) + 1 );
4386     }
4387     else {
4388         for (++MARK; MARK <= SP; MARK++) {
4389             SV * const sv = newSV(0);
4390             if (*MARK)
4391                 sv_setsv(sv, *MARK);
4392             av_store(ary, AvFILLp(ary)+1, sv);
4393         }
4394         SP = ORIGMARK;
4395         PUSHi( AvFILLp(ary) + 1 );
4396     }
4397     RETURN;
4398 }
4399
4400 PP(pp_shift)
4401 {
4402     dVAR;
4403     dSP;
4404     AV * const av = (AV*)POPs;
4405     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4406     EXTEND(SP, 1);
4407     assert (sv);
4408     if (AvREAL(av))
4409         (void)sv_2mortal(sv);
4410     PUSHs(sv);
4411     RETURN;
4412 }
4413
4414 PP(pp_unshift)
4415 {
4416     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4417     register AV *ary = (AV*)*++MARK;
4418     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4419
4420     if (mg) {
4421         *MARK-- = SvTIED_obj((SV*)ary, mg);
4422         PUSHMARK(MARK);
4423         PUTBACK;
4424         ENTER;
4425         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4426         LEAVE;
4427         SPAGAIN;
4428     }
4429     else {
4430         register I32 i = 0;
4431         av_unshift(ary, SP - MARK);
4432         while (MARK < SP) {
4433             SV * const sv = newSVsv(*++MARK);
4434             (void)av_store(ary, i++, sv);
4435         }
4436     }
4437     SP = ORIGMARK;
4438     PUSHi( AvFILL(ary) + 1 );
4439     RETURN;
4440 }
4441
4442 PP(pp_reverse)
4443 {
4444     dVAR; dSP; dMARK;
4445     SV ** const oldsp = SP;
4446
4447     if (GIMME == G_ARRAY) {
4448         MARK++;
4449         while (MARK < SP) {
4450             register SV * const tmp = *MARK;
4451             *MARK++ = *SP;
4452             *SP-- = tmp;
4453         }
4454         /* safe as long as stack cannot get extended in the above */
4455         SP = oldsp;
4456     }
4457     else {
4458         register char *up;
4459         register char *down;
4460         register I32 tmp;
4461         dTARGET;
4462         STRLEN len;
4463         PADOFFSET padoff_du;
4464
4465         SvUTF8_off(TARG);                               /* decontaminate */
4466         if (SP - MARK > 1)
4467             do_join(TARG, &PL_sv_no, MARK, SP);
4468         else
4469             sv_setsv(TARG, (SP > MARK)
4470                     ? *SP
4471                     : (padoff_du = find_rundefsvoffset(),
4472                         (padoff_du == NOT_IN_PAD
4473                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4474                         ? DEFSV : PAD_SVl(padoff_du)));
4475         up = SvPV_force(TARG, len);
4476         if (len > 1) {
4477             if (DO_UTF8(TARG)) {        /* first reverse each character */
4478                 U8* s = (U8*)SvPVX(TARG);
4479                 const U8* send = (U8*)(s + len);
4480                 while (s < send) {
4481                     if (UTF8_IS_INVARIANT(*s)) {
4482                         s++;
4483                         continue;
4484                     }
4485                     else {
4486                         if (!utf8_to_uvchr(s, 0))
4487                             break;
4488                         up = (char*)s;
4489                         s += UTF8SKIP(s);
4490                         down = (char*)(s - 1);
4491                         /* reverse this character */
4492                         while (down > up) {
4493                             tmp = *up;
4494                             *up++ = *down;
4495                             *down-- = (char)tmp;
4496                         }
4497                     }
4498                 }
4499                 up = SvPVX(TARG);
4500             }
4501             down = SvPVX(TARG) + len - 1;
4502             while (down > up) {
4503                 tmp = *up;
4504                 *up++ = *down;
4505                 *down-- = (char)tmp;
4506             }
4507             (void)SvPOK_only_UTF8(TARG);
4508         }
4509         SP = MARK + 1;
4510         SETTARG;
4511     }
4512     RETURN;
4513 }
4514
4515 PP(pp_split)
4516 {
4517     dVAR; dSP; dTARG;
4518     AV *ary;
4519     register IV limit = POPi;                   /* note, negative is forever */
4520     SV * const sv = POPs;
4521     STRLEN len;
4522     register const char *s = SvPV_const(sv, len);
4523     const bool do_utf8 = DO_UTF8(sv);
4524     const char *strend = s + len;
4525     register PMOP *pm;
4526     register REGEXP *rx;
4527     register SV *dstr;
4528     register const char *m;
4529     I32 iters = 0;
4530     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4531     I32 maxiters = slen + 10;
4532     const char *orig;
4533     const I32 origlimit = limit;
4534     I32 realarray = 0;
4535     I32 base;
4536     const I32 gimme = GIMME_V;
4537     const I32 oldsave = PL_savestack_ix;
4538     I32 make_mortal = 1;
4539     bool multiline = 0;
4540     MAGIC *mg = NULL;
4541
4542 #ifdef DEBUGGING
4543     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4544 #else
4545     pm = (PMOP*)POPs;
4546 #endif
4547     if (!pm || !s)
4548         DIE(aTHX_ "panic: pp_split");
4549     rx = PM_GETRE(pm);
4550
4551     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4552              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4553
4554     RX_MATCH_UTF8_set(rx, do_utf8);
4555
4556     if (pm->op_pmreplroot) {
4557 #ifdef USE_ITHREADS
4558         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4559 #else
4560         ary = GvAVn((GV*)pm->op_pmreplroot);
4561 #endif
4562     }
4563     else if (gimme != G_ARRAY)
4564         ary = GvAVn(PL_defgv);
4565     else
4566         ary = NULL;
4567     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4568         realarray = 1;
4569         PUTBACK;
4570         av_extend(ary,0);
4571         av_clear(ary);
4572         SPAGAIN;
4573         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4574             PUSHMARK(SP);
4575             XPUSHs(SvTIED_obj((SV*)ary, mg));
4576         }
4577         else {
4578             if (!AvREAL(ary)) {
4579                 I32 i;
4580                 AvREAL_on(ary);
4581                 AvREIFY_off(ary);
4582                 for (i = AvFILLp(ary); i >= 0; i--)
4583                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4584             }
4585             /* temporarily switch stacks */
4586             SAVESWITCHSTACK(PL_curstack, ary);
4587             make_mortal = 0;
4588         }
4589     }
4590     base = SP - PL_stack_base;
4591     orig = s;
4592     if (pm->op_pmflags & PMf_SKIPWHITE) {
4593         if (pm->op_pmflags & PMf_LOCALE) {
4594             while (isSPACE_LC(*s))
4595                 s++;
4596         }
4597         else {
4598             while (isSPACE(*s))
4599                 s++;
4600         }
4601     }
4602     if (pm->op_pmflags & PMf_MULTILINE) {
4603         multiline = 1;
4604     }
4605
4606     if (!limit)
4607         limit = maxiters + 2;
4608     if (pm->op_pmflags & PMf_WHITE) {
4609         while (--limit) {
4610             m = s;
4611             while (m < strend &&
4612                    !((pm->op_pmflags & PMf_LOCALE)
4613                      ? isSPACE_LC(*m) : isSPACE(*m)))
4614                 ++m;
4615             if (m >= strend)
4616                 break;
4617
4618             dstr = newSVpvn(s, m-s);
4619             if (make_mortal)
4620                 sv_2mortal(dstr);
4621             if (do_utf8)
4622                 (void)SvUTF8_on(dstr);
4623             XPUSHs(dstr);
4624
4625             s = m + 1;
4626             while (s < strend &&
4627                    ((pm->op_pmflags & PMf_LOCALE)
4628                     ? isSPACE_LC(*s) : isSPACE(*s)))
4629                 ++s;
4630         }
4631     }
4632     else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4633         while (--limit) {
4634             for (m = s; m < strend && *m != '\n'; m++)
4635                 ;
4636             m++;
4637             if (m >= strend)
4638                 break;
4639             dstr = newSVpvn(s, m-s);
4640             if (make_mortal)
4641                 sv_2mortal(dstr);
4642             if (do_utf8)
4643                 (void)SvUTF8_on(dstr);
4644             XPUSHs(dstr);
4645             s = m;
4646         }
4647     }
4648     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4649              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4650              && (rx->reganch & ROPT_CHECK_ALL)
4651              && !(rx->reganch & ROPT_ANCH)) {
4652         const int tail = (rx->reganch & RE_INTUIT_TAIL);
4653         SV * const csv = CALLREG_INTUIT_STRING(rx);
4654
4655         len = rx->minlen;
4656         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4657             const char c = *SvPV_nolen_const(csv);
4658             while (--limit) {
4659                 for (m = s; m < strend && *m != c; m++)
4660                     ;
4661                 if (m >= strend)
4662                     break;
4663                 dstr = newSVpvn(s, m-s);
4664                 if (make_mortal)
4665                     sv_2mortal(dstr);
4666                 if (do_utf8)
4667                     (void)SvUTF8_on(dstr);
4668                 XPUSHs(dstr);
4669                 /* The rx->minlen is in characters but we want to step
4670                  * s ahead by bytes. */
4671                 if (do_utf8)
4672                     s = (char*)utf8_hop((U8*)m, len);
4673                 else
4674                     s = m + len; /* Fake \n at the end */
4675             }
4676         }
4677         else {
4678             while (s < strend && --limit &&
4679               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4680                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4681             {
4682                 dstr = newSVpvn(s, m-s);
4683                 if (make_mortal)
4684                     sv_2mortal(dstr);
4685                 if (do_utf8)
4686                     (void)SvUTF8_on(dstr);
4687                 XPUSHs(dstr);
4688                 /* The rx->minlen is in characters but we want to step
4689                  * s ahead by bytes. */
4690                 if (do_utf8)
4691                     s = (char*)utf8_hop((U8*)m, len);
4692                 else
4693                     s = m + len; /* Fake \n at the end */
4694             }
4695         }
4696     }
4697     else {
4698         maxiters += slen * rx->nparens;
4699         while (s < strend && --limit)
4700         {
4701             I32 rex_return;
4702             PUTBACK;
4703             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4704                             sv, NULL, 0);
4705             SPAGAIN;
4706             if (rex_return == 0)
4707                 break;
4708             TAINT_IF(RX_MATCH_TAINTED(rx));
4709             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4710                 m = s;
4711                 s = orig;
4712                 orig = rx->subbeg;
4713                 s = orig + (m - s);
4714                 strend = s + (strend - m);
4715             }
4716             m = rx->startp[0] + orig;
4717             dstr = newSVpvn(s, m-s);
4718             if (make_mortal)
4719                 sv_2mortal(dstr);
4720             if (do_utf8)
4721                 (void)SvUTF8_on(dstr);
4722             XPUSHs(dstr);
4723             if (rx->nparens) {
4724                 I32 i;
4725                 for (i = 1; i <= (I32)rx->nparens; i++) {
4726                     s = rx->startp[i] + orig;
4727                     m = rx->endp[i] + orig;
4728
4729                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4730                        parens that didn't match -- they should be set to
4731                        undef, not the empty string */
4732                     if (m >= orig && s >= orig) {
4733                         dstr = newSVpvn(s, m-s);
4734                     }
4735                     else
4736                         dstr = &PL_sv_undef;  /* undef, not "" */
4737                     if (make_mortal)
4738                         sv_2mortal(dstr);
4739                     if (do_utf8)
4740                         (void)SvUTF8_on(dstr);
4741                     XPUSHs(dstr);
4742                 }
4743             }
4744             s = rx->endp[0] + orig;
4745         }
4746     }
4747
4748     iters = (SP - PL_stack_base) - base;
4749     if (iters > maxiters)
4750         DIE(aTHX_ "Split loop");
4751
4752     /* keep field after final delim? */
4753     if (s < strend || (iters && origlimit)) {
4754         const STRLEN l = strend - s;
4755         dstr = newSVpvn(s, l);
4756         if (make_mortal)
4757             sv_2mortal(dstr);
4758         if (do_utf8)
4759             (void)SvUTF8_on(dstr);
4760         XPUSHs(dstr);
4761         iters++;
4762     }
4763     else if (!origlimit) {
4764         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4765             if (TOPs && !make_mortal)
4766                 sv_2mortal(TOPs);
4767             iters--;
4768             *SP-- = &PL_sv_undef;
4769         }
4770     }
4771
4772     PUTBACK;
4773     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4774     SPAGAIN;
4775     if (realarray) {
4776         if (!mg) {
4777             if (SvSMAGICAL(ary)) {
4778                 PUTBACK;
4779                 mg_set((SV*)ary);
4780                 SPAGAIN;
4781             }
4782             if (gimme == G_ARRAY) {
4783                 EXTEND(SP, iters);
4784                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4785                 SP += iters;
4786                 RETURN;
4787             }
4788         }
4789         else {
4790             PUTBACK;
4791             ENTER;
4792             call_method("PUSH",G_SCALAR|G_DISCARD);
4793             LEAVE;
4794             SPAGAIN;
4795             if (gimme == G_ARRAY) {
4796                 I32 i;
4797                 /* EXTEND should not be needed - we just popped them */
4798                 EXTEND(SP, iters);
4799                 for (i=0; i < iters; i++) {
4800                     SV **svp = av_fetch(ary, i, FALSE);
4801                     PUSHs((svp) ? *svp : &PL_sv_undef);
4802                 }
4803                 RETURN;
4804             }
4805         }
4806     }
4807     else {
4808         if (gimme == G_ARRAY)
4809             RETURN;
4810     }
4811
4812     GETTARGET;
4813     PUSHi(iters);
4814     RETURN;
4815 }
4816
4817 PP(pp_lock)
4818 {
4819     dVAR;
4820     dSP;
4821     dTOPss;
4822     SV *retsv = sv;
4823     SvLOCK(sv);
4824     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4825         || SvTYPE(retsv) == SVt_PVCV) {
4826         retsv = refto(retsv);
4827     }
4828     SETs(retsv);
4829     RETURN;
4830 }
4831
4832
4833 PP(unimplemented_op)
4834 {
4835     dVAR;
4836     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4837         PL_op->op_type);
4838 }
4839
4840 /*
4841  * Local variables:
4842  * c-indentation-style: bsd
4843  * c-basic-offset: 4
4844  * indent-tabs-mode: t
4845  * End:
4846  *
4847  * ex: set ts=8 sts=4 sw=4 noet:
4848  */