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