pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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
  13  *  to discover, and no knowing what you'll find round a corner.
  14  *  And Elves, sir!'                            --Samwise Gamgee
  15  *
  16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
  17  */
  18
  19 /* This file contains general pp ("push/pop") functions that execute the
  20  * opcodes that make up a perl program. A typical pp function expects to
  21  * find its arguments on the stack, and usually pushes its results onto
  22  * the stack, hence the 'pp' terminology. Each OP structure contains
  23  * a pointer to the relevant pp_foo() function.
  24  */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_PP_C
  28 #include "perl.h"
  29 #include "keywords.h"
  30
  31 #include "reentr.h"
  32
  33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  34    it, since pid_t is an integral type.
  35    --AD  2/20/1998
  36 */
  37 #ifdef NEED_GETPID_PROTO
  38 extern Pid_t getpid (void);
  39 #endif
  40
  41 /*
  42  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
  43  * This switches them over to IEEE.
  44  */
  45 #if defined(LIBM_LIB_VERSION)
  46     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
  47 #endif
  48
  49 /* variations on pp_null */
  50
  51 PP(pp_stub)
  52 {
  53     dVAR;
  54     dSP;
  55     if (GIMME_V == G_SCALAR)
  56         XPUSHs(&PL_sv_undef);
  57     RETURN;
  58 }
  59
  60 /* Pushy stuff. */
  61
  62 PP(pp_padav)
  63 {
  64     dVAR; dSP; dTARGET;
  65     I32 gimme;
  66     assert(SvTYPE(TARG) == SVt_PVAV);
  67     if (PL_op->op_private & OPpLVAL_INTRO)
  68         if (!(PL_op->op_private & OPpPAD_STATE))
  69             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  70     EXTEND(SP, 1);
  71     if (PL_op->op_flags & OPf_REF) {
  72         PUSHs(TARG);
  73         RETURN;
  74     } else if (LVRET) {
  75         if (GIMME == G_SCALAR)
  76             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  77         PUSHs(TARG);
  78         RETURN;
  79     }
  80     gimme = GIMME_V;
  81     if (gimme == G_ARRAY) {
  82         const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
  83         EXTEND(SP, maxarg);
  84         if (SvMAGICAL(TARG)) {
  85             U32 i;
  86             for (i=0; i < (U32)maxarg; i++) {
  87                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
  88                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  89             }
  90         }
  91         else {
  92             Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
  93         }
  94         SP += maxarg;
  95     }
  96     else if (gimme == G_SCALAR) {
  97         SV* const sv = sv_newmortal();
  98         const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
  99         sv_setiv(sv, maxarg);
 100         PUSHs(sv);
 101     }
 102     RETURN;
 103 }
 104
 105 PP(pp_padhv)
 106 {
 107     dVAR; dSP; dTARGET;
 108     I32 gimme;
 109
 110     assert(SvTYPE(TARG) == SVt_PVHV);
 111     XPUSHs(TARG);
 112     if (PL_op->op_private & OPpLVAL_INTRO)
 113         if (!(PL_op->op_private & OPpPAD_STATE))
 114             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 115     if (PL_op->op_flags & OPf_REF)
 116         RETURN;
 117     else if (LVRET) {
 118         if (GIMME == G_SCALAR)
 119             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 120         RETURN;
 121     }
 122     gimme = GIMME_V;
 123     if (gimme == G_ARRAY) {
 124         RETURNOP(do_kv());
 125     }
 126     else if (gimme == G_SCALAR) {
 127         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
 128         SETs(sv);
 129     }
 130     RETURN;
 131 }
 132
 133 /* Translations. */
 134
 135 static const char S_no_symref_sv[] =
 136     "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
 137
 138 PP(pp_rv2gv)
 139 {
 140     dVAR; dSP; dTOPss;
 141
 142     if (SvROK(sv)) {
 143       wasref:
 144         tryAMAGICunDEREF(to_gv);
 145
 146         sv = SvRV(sv);
 147         if (SvTYPE(sv) == SVt_PVIO) {
 148             GV * const gv = MUTABLE_GV(sv_newmortal());
 149             gv_init(gv, 0, "", 0, 0);
 150             GvIOp(gv) = MUTABLE_IO(sv);
 151             SvREFCNT_inc_void_NN(sv);
 152             sv = MUTABLE_SV(gv);
 153         }
 154         else if (!isGV_with_GP(sv))
 155             DIE(aTHX_ "Not a GLOB reference");
 156     }
 157     else {
 158         if (!isGV_with_GP(sv)) {
 159             if (SvGMAGICAL(sv)) {
 160                 mg_get(sv);
 161                 if (SvROK(sv))
 162                     goto wasref;
 163             }
 164             if (!SvOK(sv) && sv != &PL_sv_undef) {
 165                 /* If this is a 'my' scalar and flag is set then vivify
 166                  * NI-S 1999/05/07
 167                  */
 168                 if (SvREADONLY(sv))
 169                     Perl_croak(aTHX_ "%s", PL_no_modify);
 170                 if (PL_op->op_private & OPpDEREF) {
 171                     GV *gv;
 172                     if (cUNOP->op_targ) {
 173                         STRLEN len;
 174                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 175                         const char * const name = SvPV(namesv, len);
 176                         gv = MUTABLE_GV(newSV(0));
 177                         gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
 178                     }
 179                     else {
 180                         const char * const name = CopSTASHPV(PL_curcop);
 181                         gv = newGVgen(name);
 182                     }
 183                     prepare_SV_for_RV(sv);
 184                     SvRV_set(sv, MUTABLE_SV(gv));
 185                     SvROK_on(sv);
 186                     SvSETMAGIC(sv);
 187                     goto wasref;
 188                 }
 189                 if (PL_op->op_flags & OPf_REF ||
 190                     PL_op->op_private & HINT_STRICT_REFS)
 191                     DIE(aTHX_ PL_no_usym, "a symbol");
 192                 if (ckWARN(WARN_UNINITIALIZED))
 193                     report_uninit(sv);
 194                 RETSETUNDEF;
 195             }
 196             if ((PL_op->op_flags & OPf_SPECIAL) &&
 197                 !(PL_op->op_flags & OPf_MOD))
 198             {
 199                 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
 200                 if (!temp
 201                     && (!is_gv_magical_sv(sv,0)
 202                         || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
 203                                                         SVt_PVGV))))) {
 204                     RETSETUNDEF;
 205                 }
 206                 sv = temp;
 207             }
 208             else {
 209                 if (PL_op->op_private & HINT_STRICT_REFS)
 210                     DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
 211                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 212                     == OPpDONT_INIT_GV) {
 213                     /* We are the target of a coderef assignment.  Return
 214                        the scalar unchanged, and let pp_sasssign deal with
 215                        things.  */
 216                     RETURN;
 217                 }
 218                 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
 219             }
 220         }
 221     }
 222     if (PL_op->op_private & OPpLVAL_INTRO)
 223         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 224     SETs(sv);
 225     RETURN;
 226 }
 227
 228 /* Helper function for pp_rv2sv and pp_rv2av  */
 229 GV *
 230 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 231                 const svtype type, SV ***spp)
 232 {
 233     dVAR;
 234     GV *gv;
 235
 236     PERL_ARGS_ASSERT_SOFTREF2XV;
 237
 238     if (PL_op->op_private & HINT_STRICT_REFS) {
 239         if (SvOK(sv))
 240             Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 241         else
 242             Perl_die(aTHX_ PL_no_usym, what);
 243     }
 244     if (!SvOK(sv)) {
 245         if (PL_op->op_flags & OPf_REF)
 246             Perl_die(aTHX_ PL_no_usym, what);
 247         if (ckWARN(WARN_UNINITIALIZED))
 248             report_uninit(sv);
 249         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 250             (*spp)--;
 251             return NULL;
 252         }
 253         **spp = &PL_sv_undef;
 254         return NULL;
 255     }
 256     if ((PL_op->op_flags & OPf_SPECIAL) &&
 257         !(PL_op->op_flags & OPf_MOD))
 258         {
 259             gv = gv_fetchsv(sv, 0, type);
 260             if (!gv
 261                 && (!is_gv_magical_sv(sv,0)
 262                     || !(gv = gv_fetchsv(sv, GV_ADD, type))))
 263                 {
 264                     **spp = &PL_sv_undef;
 265                     return NULL;
 266                 }
 267         }
 268     else {
 269         gv = gv_fetchsv(sv, GV_ADD, type);
 270     }
 271     return gv;
 272 }
 273
 274 PP(pp_rv2sv)
 275 {
 276     dVAR; dSP; dTOPss;
 277     GV *gv = NULL;
 278
 279     if (SvROK(sv)) {
 280       wasref:
 281         tryAMAGICunDEREF(to_sv);
 282
 283         sv = SvRV(sv);
 284         switch (SvTYPE(sv)) {
 285         case SVt_PVAV:
 286         case SVt_PVHV:
 287         case SVt_PVCV:
 288         case SVt_PVFM:
 289         case SVt_PVIO:
 290             DIE(aTHX_ "Not a SCALAR reference");
 291         default: NOOP;
 292         }
 293     }
 294     else {
 295         gv = MUTABLE_GV(sv);
 296
 297         if (!isGV_with_GP(gv)) {
 298             if (SvGMAGICAL(sv)) {
 299                 mg_get(sv);
 300                 if (SvROK(sv))
 301                     goto wasref;
 302             }
 303             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 304             if (!gv)
 305                 RETURN;
 306         }
 307         sv = GvSVn(gv);
 308     }
 309     if (PL_op->op_flags & OPf_MOD) {
 310         if (PL_op->op_private & OPpLVAL_INTRO) {
 311             if (cUNOP->op_first->op_type == OP_NULL)
 312                 sv = save_scalar(MUTABLE_GV(TOPs));
 313             else if (gv)
 314                 sv = save_scalar(gv);
 315             else
 316                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 317         }
 318         else if (PL_op->op_private & OPpDEREF)
 319             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 320     }
 321     SETs(sv);
 322     RETURN;
 323 }
 324
 325 PP(pp_av2arylen)
 326 {
 327     dVAR; dSP;
 328     AV * const av = MUTABLE_AV(TOPs);
 329     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 330     if (lvalue) {
 331         SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 332         if (!*sv) {
 333             *sv = newSV_type(SVt_PVMG);
 334             sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 335         }
 336         SETs(*sv);
 337     } else {
 338         SETs(sv_2mortal(newSViv(
 339             AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
 340         )));
 341     }
 342     RETURN;
 343 }
 344
 345 PP(pp_pos)
 346 {
 347     dVAR; dSP; dTARGET; dPOPss;
 348
 349     if (PL_op->op_flags & OPf_MOD || LVRET) {
 350         if (SvTYPE(TARG) < SVt_PVLV) {
 351             sv_upgrade(TARG, SVt_PVLV);
 352             sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
 353         }
 354
 355         LvTYPE(TARG) = '.';
 356         if (LvTARG(TARG) != sv) {
 357             SvREFCNT_dec(LvTARG(TARG));
 358             LvTARG(TARG) = SvREFCNT_inc_simple(sv);
 359         }
 360         PUSHs(TARG);    /* no SvSETMAGIC */
 361         RETURN;
 362     }
 363     else {
 364         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 365             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
 366             if (mg && mg->mg_len >= 0) {
 367                 I32 i = mg->mg_len;
 368                 if (DO_UTF8(sv))
 369                     sv_pos_b2u(sv, &i);
 370                 PUSHi(i + CopARYBASE_get(PL_curcop));
 371                 RETURN;
 372             }
 373         }
 374         RETPUSHUNDEF;
 375     }
 376 }
 377
 378 PP(pp_rv2cv)
 379 {
 380     dVAR; dSP;
 381     GV *gv;
 382     HV *stash_unused;
 383     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 384         ? 0
 385         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
 386             ? GV_ADD|GV_NOEXPAND
 387             : GV_ADD;
 388     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 389     /* (But not in defined().) */
 390
 391     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 392     if (cv) {
 393         if (CvCLONE(cv))
 394             cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 395         if ((PL_op->op_private & OPpLVAL_INTRO)) {
 396             if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
 397                 cv = GvCV(gv);
 398             if (!CvLVALUE(cv))
 399                 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
 400         }
 401     }
 402     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 403         cv = MUTABLE_CV(gv);
 404     }
 405     else
 406         cv = MUTABLE_CV(&PL_sv_undef);
 407     SETs(MUTABLE_SV(cv));
 408     RETURN;
 409 }
 410
 411 PP(pp_prototype)
 412 {
 413     dVAR; dSP;
 414     CV *cv;
 415     HV *stash;
 416     GV *gv;
 417     SV *ret = &PL_sv_undef;
 418
 419     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 420         const char * s = SvPVX_const(TOPs);
 421         if (strnEQ(s, "CORE::", 6)) {
 422             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 423             if (code < 0) {     /* Overridable. */
 424 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 425                 int i = 0, n = 0, seen_question = 0, defgv = 0;
 426                 I32 oa;
 427                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 428
 429                 if (code == -KEY_chop || code == -KEY_chomp
 430                         || code == -KEY_exec || code == -KEY_system)
 431                     goto set;
 432                 if (code == -KEY_mkdir) {
 433                     ret = newSVpvs_flags("_;$", SVs_TEMP);
 434                     goto set;
 435                 }
 436                 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
 437                     ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
 438                     goto set;
 439                 }
 440                 if (code == -KEY_readpipe) {
 441                     s = "CORE::backtick";
 442                 }
 443                 while (i < MAXO) {      /* The slow way. */
 444                     if (strEQ(s + 6, PL_op_name[i])
 445                         || strEQ(s + 6, PL_op_desc[i]))
 446                     {
 447                         goto found;
 448                     }
 449                     i++;
 450                 }
 451                 goto nonesuch;          /* Should not happen... */
 452               found:
 453                 defgv = PL_opargs[i] & OA_DEFGV;
 454                 oa = PL_opargs[i] >> OASHIFT;
 455                 while (oa) {
 456                     if (oa & OA_OPTIONAL && !seen_question && !defgv) {
 457                         seen_question = 1;
 458                         str[n++] = ';';
 459                     }
 460                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 461                         && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
 462                         /* But globs are already references (kinda) */
 463                         && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
 464                     ) {
 465                         str[n++] = '\\';
 466                     }
 467                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 468                     oa = oa >> 4;
 469                 }
 470                 if (defgv && str[n - 1] == '$')
 471                     str[n - 1] = '_';
 472                 str[n++] = '\0';
 473                 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
 474             }
 475             else if (code)              /* Non-Overridable */
 476                 goto set;
 477             else {                      /* None such */
 478               nonesuch:
 479                 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
 480             }
 481         }
 482     }
 483     cv = sv_2cv(TOPs, &stash, &gv, 0);
 484     if (cv && SvPOK(cv))
 485         ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
 486   set:
 487     SETs(ret);
 488     RETURN;
 489 }
 490
 491 PP(pp_anoncode)
 492 {
 493     dVAR; dSP;
 494     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 495     if (CvCLONE(cv))
 496         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 497     EXTEND(SP,1);
 498     PUSHs(MUTABLE_SV(cv));
 499     RETURN;
 500 }
 501
 502 PP(pp_srefgen)
 503 {
 504     dVAR; dSP;
 505     *SP = refto(*SP);
 506     RETURN;
 507 }
 508
 509 PP(pp_refgen)
 510 {
 511     dVAR; dSP; dMARK;
 512     if (GIMME != G_ARRAY) {
 513         if (++MARK <= SP)
 514             *MARK = *SP;
 515         else
 516             *MARK = &PL_sv_undef;
 517         *MARK = refto(*MARK);
 518         SP = MARK;
 519         RETURN;
 520     }
 521     EXTEND_MORTAL(SP - MARK);
 522     while (++MARK <= SP)
 523         *MARK = refto(*MARK);
 524     RETURN;
 525 }
 526
 527 STATIC SV*
 528 S_refto(pTHX_ SV *sv)
 529 {
 530     dVAR;
 531     SV* rv;
 532
 533     PERL_ARGS_ASSERT_REFTO;
 534
 535     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 536         if (LvTARGLEN(sv))
 537             vivify_defelem(sv);
 538         if (!(sv = LvTARG(sv)))
 539             sv = &PL_sv_undef;
 540         else
 541             SvREFCNT_inc_void_NN(sv);
 542     }
 543     else if (SvTYPE(sv) == SVt_PVAV) {
 544         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 545             av_reify(MUTABLE_AV(sv));
 546         SvTEMP_off(sv);
 547         SvREFCNT_inc_void_NN(sv);
 548     }
 549     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 550         sv = newSVsv(sv);
 551     else {
 552         SvTEMP_off(sv);
 553         SvREFCNT_inc_void_NN(sv);
 554     }
 555     rv = sv_newmortal();
 556     sv_upgrade(rv, SVt_IV);
 557     SvRV_set(rv, sv);
 558     SvROK_on(rv);
 559     return rv;
 560 }
 561
 562 PP(pp_ref)
 563 {
 564     dVAR; dSP; dTARGET;
 565     const char *pv;
 566     SV * const sv = POPs;
 567
 568     if (sv)
 569         SvGETMAGIC(sv);
 570
 571     if (!sv || !SvROK(sv))
 572         RETPUSHNO;
 573
 574     pv = sv_reftype(SvRV(sv),TRUE);
 575     PUSHp(pv, strlen(pv));
 576     RETURN;
 577 }
 578
 579 PP(pp_bless)
 580 {
 581     dVAR; dSP;
 582     HV *stash;
 583
 584     if (MAXARG == 1)
 585         stash = CopSTASH(PL_curcop);
 586     else {
 587         SV * const ssv = POPs;
 588         STRLEN len;
 589         const char *ptr;
 590
 591         if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
 592             Perl_croak(aTHX_ "Attempt to bless into a reference");
 593         ptr = SvPV_const(ssv,len);
 594         if (len == 0)
 595             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 596                            "Explicit blessing to '' (assuming package main)");
 597         stash = gv_stashpvn(ptr, len, GV_ADD);
 598     }
 599
 600     (void)sv_bless(TOPs, stash);
 601     RETURN;
 602 }
 603
 604 PP(pp_gelem)
 605 {
 606     dVAR; dSP;
 607
 608     SV *sv = POPs;
 609     const char * const elem = SvPV_nolen_const(sv);
 610     GV * const gv = MUTABLE_GV(POPs);
 611     SV * tmpRef = NULL;
 612
 613     sv = NULL;
 614     if (elem) {
 615         /* elem will always be NUL terminated.  */
 616         const char * const second_letter = elem + 1;
 617         switch (*elem) {
 618         case 'A':
 619             if (strEQ(second_letter, "RRAY"))
 620                 tmpRef = MUTABLE_SV(GvAV(gv));
 621             break;
 622         case 'C':
 623             if (strEQ(second_letter, "ODE"))
 624                 tmpRef = MUTABLE_SV(GvCVu(gv));
 625             break;
 626         case 'F':
 627             if (strEQ(second_letter, "ILEHANDLE")) {
 628                 /* finally deprecated in 5.8.0 */
 629                 deprecate("*glob{FILEHANDLE}");
 630                 tmpRef = MUTABLE_SV(GvIOp(gv));
 631             }
 632             else
 633                 if (strEQ(second_letter, "ORMAT"))
 634                     tmpRef = MUTABLE_SV(GvFORM(gv));
 635             break;
 636         case 'G':
 637             if (strEQ(second_letter, "LOB"))
 638                 tmpRef = MUTABLE_SV(gv);
 639             break;
 640         case 'H':
 641             if (strEQ(second_letter, "ASH"))
 642                 tmpRef = MUTABLE_SV(GvHV(gv));
 643             break;
 644         case 'I':
 645             if (*second_letter == 'O' && !elem[2])
 646                 tmpRef = MUTABLE_SV(GvIOp(gv));
 647             break;
 648         case 'N':
 649             if (strEQ(second_letter, "AME"))
 650                 sv = newSVhek(GvNAME_HEK(gv));
 651             break;
 652         case 'P':
 653             if (strEQ(second_letter, "ACKAGE")) {
 654                 const HV * const stash = GvSTASH(gv);
 655                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 656                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 657             }
 658             break;
 659         case 'S':
 660             if (strEQ(second_letter, "CALAR"))
 661                 tmpRef = GvSVn(gv);
 662             break;
 663         }
 664     }
 665     if (tmpRef)
 666         sv = newRV(tmpRef);
 667     if (sv)
 668         sv_2mortal(sv);
 669     else
 670         sv = &PL_sv_undef;
 671     XPUSHs(sv);
 672     RETURN;
 673 }
 674
 675 /* Pattern matching */
 676
 677 PP(pp_study)
 678 {
 679     dVAR; dSP; dPOPss;
 680     register unsigned char *s;
 681     register I32 pos;
 682     register I32 ch;
 683     register I32 *sfirst;
 684     register I32 *snext;
 685     STRLEN len;
 686
 687     if (sv == PL_lastscream) {
 688         if (SvSCREAM(sv))
 689             RETPUSHYES;
 690     }
 691     s = (unsigned char*)(SvPV(sv, len));
 692     pos = len;
 693     if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
 694         /* No point in studying a zero length string, and not safe to study
 695            anything that doesn't appear to be a simple scalar (and hence might
 696            change between now and when the regexp engine runs without our set
 697            magic ever running) such as a reference to an object with overloaded
 698            stringification.  */
 699         RETPUSHNO;
 700     }
 701
 702     if (PL_lastscream) {
 703         SvSCREAM_off(PL_lastscream);
 704         SvREFCNT_dec(PL_lastscream);
 705     }
 706     PL_lastscream = SvREFCNT_inc_simple(sv);
 707
 708     s = (unsigned char*)(SvPV(sv, len));
 709     pos = len;
 710     if (pos <= 0)
 711         RETPUSHNO;
 712     if (pos > PL_maxscream) {
 713         if (PL_maxscream < 0) {
 714             PL_maxscream = pos + 80;
 715             Newx(PL_screamfirst, 256, I32);
 716             Newx(PL_screamnext, PL_maxscream, I32);
 717         }
 718         else {
 719             PL_maxscream = pos + pos / 4;
 720             Renew(PL_screamnext, PL_maxscream, I32);
 721         }
 722     }
 723
 724     sfirst = PL_screamfirst;
 725     snext = PL_screamnext;
 726
 727     if (!sfirst || !snext)
 728         DIE(aTHX_ "do_study: out of memory");
 729
 730     for (ch = 256; ch; --ch)
 731         *sfirst++ = -1;
 732     sfirst -= 256;
 733
 734     while (--pos >= 0) {
 735         register const I32 ch = s[pos];
 736         if (sfirst[ch] >= 0)
 737             snext[pos] = sfirst[ch] - pos;
 738         else
 739             snext[pos] = -pos;
 740         sfirst[ch] = pos;
 741     }
 742
 743     SvSCREAM_on(sv);
 744     /* piggyback on m//g magic */
 745     sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
 746     RETPUSHYES;
 747 }
 748
 749 PP(pp_trans)
 750 {
 751     dVAR; dSP; dTARG;
 752     SV *sv;
 753
 754     if (PL_op->op_flags & OPf_STACKED)
 755         sv = POPs;
 756     else if (PL_op->op_private & OPpTARGET_MY)
 757         sv = GETTARGET;
 758     else {
 759         sv = DEFSV;
 760         EXTEND(SP,1);
 761     }
 762     TARG = sv_newmortal();
 763     PUSHi(do_trans(sv));
 764     RETURN;
 765 }
 766
 767 /* Lvalue operators. */
 768
 769 PP(pp_schop)
 770 {
 771     dVAR; dSP; dTARGET;
 772     do_chop(TARG, TOPs);
 773     SETTARG;
 774     RETURN;
 775 }
 776
 777 PP(pp_chop)
 778 {
 779     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
 780     while (MARK < SP)
 781         do_chop(TARG, *++MARK);
 782     SP = ORIGMARK;
 783     XPUSHTARG;
 784     RETURN;
 785 }
 786
 787 PP(pp_schomp)
 788 {
 789     dVAR; dSP; dTARGET;
 790     SETi(do_chomp(TOPs));
 791     RETURN;
 792 }
 793
 794 PP(pp_chomp)
 795 {
 796     dVAR; dSP; dMARK; dTARGET;
 797     register I32 count = 0;
 798
 799     while (SP > MARK)
 800         count += do_chomp(POPs);
 801     XPUSHi(count);
 802     RETURN;
 803 }
 804
 805 PP(pp_undef)
 806 {
 807     dVAR; dSP;
 808     SV *sv;
 809
 810     if (!PL_op->op_private) {
 811         EXTEND(SP, 1);
 812         RETPUSHUNDEF;
 813     }
 814
 815     sv = POPs;
 816     if (!sv)
 817         RETPUSHUNDEF;
 818
 819     SV_CHECK_THINKFIRST_COW_DROP(sv);
 820
 821     switch (SvTYPE(sv)) {
 822     case SVt_NULL:
 823         break;
 824     case SVt_PVAV:
 825         av_undef(MUTABLE_AV(sv));
 826         break;
 827     case SVt_PVHV:
 828         hv_undef(MUTABLE_HV(sv));
 829         break;
 830     case SVt_PVCV:
 831         if (cv_const_sv((const CV *)sv))
 832             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
 833                            CvANON((const CV *)sv) ? "(anonymous)"
 834                            : GvENAME(CvGV((const CV *)sv)));
 835         /* FALLTHROUGH */
 836     case SVt_PVFM:
 837         {
 838             /* let user-undef'd sub keep its identity */
 839             GV* const gv = CvGV((const CV *)sv);
 840             cv_undef(MUTABLE_CV(sv));
 841             CvGV((const CV *)sv) = gv;
 842         }
 843         break;
 844     case SVt_PVGV:
 845         if (SvFAKE(sv)) {
 846             SvSetMagicSV(sv, &PL_sv_undef);
 847             break;
 848         }
 849         else if (isGV_with_GP(sv)) {
 850             GP *gp;
 851             HV *stash;
 852
 853             /* undef *Foo:: */
 854             if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
 855                 mro_isa_changed_in(stash);
 856             /* undef *Pkg::meth_name ... */
 857             else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
 858                     && HvNAME_get(stash))
 859                 mro_method_changed_in(stash);
 860
 861             gp_free(MUTABLE_GV(sv));
 862             Newxz(gp, 1, GP);
 863             GvGP(sv) = gp_ref(gp);
 864             GvSV(sv) = newSV(0);
 865             GvLINE(sv) = CopLINE(PL_curcop);
 866             GvEGV(sv) = MUTABLE_GV(sv);
 867             GvMULTI_on(sv);
 868             break;
 869         }
 870         /* FALL THROUGH */
 871     default:
 872         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 873             SvPV_free(sv);
 874             SvPV_set(sv, NULL);
 875             SvLEN_set(sv, 0);
 876         }
 877         SvOK_off(sv);
 878         SvSETMAGIC(sv);
 879     }
 880
 881     RETPUSHUNDEF;
 882 }
 883
 884 PP(pp_predec)
 885 {
 886     dVAR; dSP;
 887     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 888         DIE(aTHX_ "%s", PL_no_modify);
 889     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 890         && SvIVX(TOPs) != IV_MIN)
 891     {
 892         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 893         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 894     }
 895     else
 896         sv_dec(TOPs);
 897     SvSETMAGIC(TOPs);
 898     return NORMAL;
 899 }
 900
 901 PP(pp_postinc)
 902 {
 903     dVAR; dSP; dTARGET;
 904     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 905         DIE(aTHX_ "%s", PL_no_modify);
 906     sv_setsv(TARG, TOPs);
 907     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 908         && SvIVX(TOPs) != IV_MAX)
 909     {
 910         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 911         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 912     }
 913     else
 914         sv_inc(TOPs);
 915     SvSETMAGIC(TOPs);
 916     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
 917     if (!SvOK(TARG))
 918         sv_setiv(TARG, 0);
 919     SETs(TARG);
 920     return NORMAL;
 921 }
 922
 923 PP(pp_postdec)
 924 {
 925     dVAR; dSP; dTARGET;
 926     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 927         DIE(aTHX_ "%s", PL_no_modify);
 928     sv_setsv(TARG, TOPs);
 929     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 930         && SvIVX(TOPs) != IV_MIN)
 931     {
 932         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 933         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 934     }
 935     else
 936         sv_dec(TOPs);
 937     SvSETMAGIC(TOPs);
 938     SETs(TARG);
 939     return NORMAL;
 940 }
 941
 942 /* Ordinary operators. */
 943
 944 PP(pp_pow)
 945 {
 946     dVAR; dSP; dATARGET; SV *svl, *svr;
 947 #ifdef PERL_PRESERVE_IVUV
 948     bool is_int = 0;
 949 #endif
 950     tryAMAGICbin(pow,opASSIGN);
 951     svl = sv_2num(TOPm1s);
 952     svr = sv_2num(TOPs);
 953 #ifdef PERL_PRESERVE_IVUV
 954     /* For integer to integer power, we do the calculation by hand wherever
 955        we're sure it is safe; otherwise we call pow() and try to convert to
 956        integer afterwards. */
 957     {
 958         SvIV_please(svr);
 959         if (SvIOK(svr)) {
 960             SvIV_please(svl);
 961             if (SvIOK(svl)) {
 962                 UV power;
 963                 bool baseuok;
 964                 UV baseuv;
 965
 966                 if (SvUOK(svr)) {
 967                     power = SvUVX(svr);
 968                 } else {
 969                     const IV iv = SvIVX(svr);
 970                     if (iv >= 0) {
 971                         power = iv;
 972                     } else {
 973                         goto float_it; /* Can't do negative powers this way.  */
 974                     }
 975                 }
 976
 977                 baseuok = SvUOK(svl);
 978                 if (baseuok) {
 979                     baseuv = SvUVX(svl);
 980                 } else {
 981                     const IV iv = SvIVX(svl);
 982                     if (iv >= 0) {
 983                         baseuv = iv;
 984                         baseuok = TRUE; /* effectively it's a UV now */
 985                     } else {
 986                         baseuv = -iv; /* abs, baseuok == false records sign */
 987                     }
 988                 }
 989                 /* now we have integer ** positive integer. */
 990                 is_int = 1;
 991
 992                 /* foo & (foo - 1) is zero only for a power of 2.  */
 993                 if (!(baseuv & (baseuv - 1))) {
 994                     /* We are raising power-of-2 to a positive integer.
 995                        The logic here will work for any base (even non-integer
 996                        bases) but it can be less accurate than
 997                        pow (base,power) or exp (power * log (base)) when the
 998                        intermediate values start to spill out of the mantissa.
 999                        With powers of 2 we know this can't happen.
1000                        And powers of 2 are the favourite thing for perl
1001                        programmers to notice ** not doing what they mean. */
1002                     NV result = 1.0;
1003                     NV base = baseuok ? baseuv : -(NV)baseuv;
1004
1005                     if (power & 1) {
1006                         result *= base;
1007                     }
1008                     while (power >>= 1) {
1009                         base *= base;
1010                         if (power & 1) {
1011                             result *= base;
1012                         }
1013                     }
1014                     SP--;
1015                     SETn( result );
1016                     SvIV_please(svr);
1017                     RETURN;
1018                 } else {
1019                     register unsigned int highbit = 8 * sizeof(UV);
1020                     register unsigned int diff = 8 * sizeof(UV);
1021                     while (diff >>= 1) {
1022                         highbit -= diff;
1023                         if (baseuv >> highbit) {
1024                             highbit += diff;
1025                         }
1026                     }
1027                     /* we now have baseuv < 2 ** highbit */
1028                     if (power * highbit <= 8 * sizeof(UV)) {
1029                         /* result will definitely fit in UV, so use UV math
1030                            on same algorithm as above */
1031                         register UV result = 1;
1032                         register UV base = baseuv;
1033                         const bool odd_power = cBOOL(power & 1);
1034                         if (odd_power) {
1035                             result *= base;
1036                         }
1037                         while (power >>= 1) {
1038                             base *= base;
1039                             if (power & 1) {
1040                                 result *= base;
1041                             }
1042                         }
1043                         SP--;
1044                         if (baseuok || !odd_power)
1045                             /* answer is positive */
1046                             SETu( result );
1047                         else if (result <= (UV)IV_MAX)
1048                             /* answer negative, fits in IV */
1049                             SETi( -(IV)result );
1050                         else if (result == (UV)IV_MIN)
1051                             /* 2's complement assumption: special case IV_MIN */
1052                             SETi( IV_MIN );
1053                         else
1054                             /* answer negative, doesn't fit */
1055                             SETn( -(NV)result );
1056                         RETURN;
1057                     }
1058                 }
1059             }
1060         }
1061     }
1062   float_it:
1063 #endif
1064     {
1065         NV right = SvNV(svr);
1066         NV left  = SvNV(svl);
1067         (void)POPs;
1068
1069 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1070     /*
1071     We are building perl with long double support and are on an AIX OS
1072     afflicted with a powl() function that wrongly returns NaNQ for any
1073     negative base.  This was reported to IBM as PMR #23047-379 on
1074     03/06/2006.  The problem exists in at least the following versions
1075     of AIX and the libm fileset, and no doubt others as well:
1076
1077         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1078         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1079         AIX 5.2.0           bos.adt.libm 5.2.0.85
1080
1081     So, until IBM fixes powl(), we provide the following workaround to
1082     handle the problem ourselves.  Our logic is as follows: for
1083     negative bases (left), we use fmod(right, 2) to check if the
1084     exponent is an odd or even integer:
1085
1086         - if odd,  powl(left, right) == -powl(-left, right)
1087         - if even, powl(left, right) ==  powl(-left, right)
1088
1089     If the exponent is not an integer, the result is rightly NaNQ, so
1090     we just return that (as NV_NAN).
1091     */
1092
1093         if (left < 0.0) {
1094             NV mod2 = Perl_fmod( right, 2.0 );
1095             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1096                 SETn( -Perl_pow( -left, right) );
1097             } else if (mod2 == 0.0) {           /* even integer */
1098                 SETn( Perl_pow( -left, right) );
1099             } else {                            /* fractional power */
1100                 SETn( NV_NAN );
1101             }
1102         } else {
1103             SETn( Perl_pow( left, right) );
1104         }
1105 #else
1106         SETn( Perl_pow( left, right) );
1107 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1108
1109 #ifdef PERL_PRESERVE_IVUV
1110         if (is_int)
1111             SvIV_please(svr);
1112 #endif
1113         RETURN;
1114     }
1115 }
1116
1117 PP(pp_multiply)
1118 {
1119     dVAR; dSP; dATARGET; SV *svl, *svr;
1120     tryAMAGICbin(mult,opASSIGN);
1121     svl = sv_2num(TOPm1s);
1122     svr = sv_2num(TOPs);
1123 #ifdef PERL_PRESERVE_IVUV
1124     SvIV_please(svr);
1125     if (SvIOK(svr)) {
1126         /* Unless the left argument is integer in range we are going to have to
1127            use NV maths. Hence only attempt to coerce the right argument if
1128            we know the left is integer.  */
1129         /* Left operand is defined, so is it IV? */
1130         SvIV_please(svl);
1131         if (SvIOK(svl)) {
1132             bool auvok = SvUOK(svl);
1133             bool buvok = SvUOK(svr);
1134             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1135             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1136             UV alow;
1137             UV ahigh;
1138             UV blow;
1139             UV bhigh;
1140
1141             if (auvok) {
1142                 alow = SvUVX(svl);
1143             } else {
1144                 const IV aiv = SvIVX(svl);
1145                 if (aiv >= 0) {
1146                     alow = aiv;
1147                     auvok = TRUE; /* effectively it's a UV now */
1148                 } else {
1149                     alow = -aiv; /* abs, auvok == false records sign */
1150                 }
1151             }
1152             if (buvok) {
1153                 blow = SvUVX(svr);
1154             } else {
1155                 const IV biv = SvIVX(svr);
1156                 if (biv >= 0) {
1157                     blow = biv;
1158                     buvok = TRUE; /* effectively it's a UV now */
1159                 } else {
1160                     blow = -biv; /* abs, buvok == false records sign */
1161                 }
1162             }
1163
1164             /* If this does sign extension on unsigned it's time for plan B  */
1165             ahigh = alow >> (4 * sizeof (UV));
1166             alow &= botmask;
1167             bhigh = blow >> (4 * sizeof (UV));
1168             blow &= botmask;
1169             if (ahigh && bhigh) {
1170                 NOOP;
1171                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1172                    which is overflow. Drop to NVs below.  */
1173             } else if (!ahigh && !bhigh) {
1174                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1175                    so the unsigned multiply cannot overflow.  */
1176                 const UV product = alow * blow;
1177                 if (auvok == buvok) {
1178                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1179                     SP--;
1180                     SETu( product );
1181                     RETURN;
1182                 } else if (product <= (UV)IV_MIN) {
1183                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1184                     /* -ve result, which could overflow an IV  */
1185                     SP--;
1186                     SETi( -(IV)product );
1187                     RETURN;
1188                 } /* else drop to NVs below. */
1189             } else {
1190                 /* One operand is large, 1 small */
1191                 UV product_middle;
1192                 if (bhigh) {
1193                     /* swap the operands */
1194                     ahigh = bhigh;
1195                     bhigh = blow; /* bhigh now the temp var for the swap */
1196                     blow = alow;
1197                     alow = bhigh;
1198                 }
1199                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1200                    multiplies can't overflow. shift can, add can, -ve can.  */
1201                 product_middle = ahigh * blow;
1202                 if (!(product_middle & topmask)) {
1203                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1204                     UV product_low;
1205                     product_middle <<= (4 * sizeof (UV));
1206                     product_low = alow * blow;
1207
1208                     /* as for pp_add, UV + something mustn't get smaller.
1209                        IIRC ANSI mandates this wrapping *behaviour* for
1210                        unsigned whatever the actual representation*/
1211                     product_low += product_middle;
1212                     if (product_low >= product_middle) {
1213                         /* didn't overflow */
1214                         if (auvok == buvok) {
1215                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1216                             SP--;
1217                             SETu( product_low );
1218                             RETURN;
1219                         } else if (product_low <= (UV)IV_MIN) {
1220                             /* 2s complement assumption again  */
1221                             /* -ve result, which could overflow an IV  */
1222                             SP--;
1223                             SETi( -(IV)product_low );
1224                             RETURN;
1225                         } /* else drop to NVs below. */
1226                     }
1227                 } /* product_middle too large */
1228             } /* ahigh && bhigh */
1229         } /* SvIOK(svl) */
1230     } /* SvIOK(svr) */
1231 #endif
1232     {
1233       NV right = SvNV(svr);
1234       NV left  = SvNV(svl);
1235       (void)POPs;
1236       SETn( left * right );
1237       RETURN;
1238     }
1239 }
1240
1241 PP(pp_divide)
1242 {
1243     dVAR; dSP; dATARGET; SV *svl, *svr;
1244     tryAMAGICbin(div,opASSIGN);
1245     svl = sv_2num(TOPm1s);
1246     svr = sv_2num(TOPs);
1247     /* Only try to do UV divide first
1248        if ((SLOPPYDIVIDE is true) or
1249            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1250             to preserve))
1251        The assumption is that it is better to use floating point divide
1252        whenever possible, only doing integer divide first if we can't be sure.
1253        If NV_PRESERVES_UV is true then we know at compile time that no UV
1254        can be too large to preserve, so don't need to compile the code to
1255        test the size of UVs.  */
1256
1257 #ifdef SLOPPYDIVIDE
1258 #  define PERL_TRY_UV_DIVIDE
1259     /* ensure that 20./5. == 4. */
1260 #else
1261 #  ifdef PERL_PRESERVE_IVUV
1262 #    ifndef NV_PRESERVES_UV
1263 #      define PERL_TRY_UV_DIVIDE
1264 #    endif
1265 #  endif
1266 #endif
1267
1268 #ifdef PERL_TRY_UV_DIVIDE
1269     SvIV_please(svr);
1270     if (SvIOK(svr)) {
1271         SvIV_please(svl);
1272         if (SvIOK(svl)) {
1273             bool left_non_neg = SvUOK(svl);
1274             bool right_non_neg = SvUOK(svr);
1275             UV left;
1276             UV right;
1277
1278             if (right_non_neg) {
1279                 right = SvUVX(svr);
1280             }
1281             else {
1282                 const IV biv = SvIVX(svr);
1283                 if (biv >= 0) {
1284                     right = biv;
1285                     right_non_neg = TRUE; /* effectively it's a UV now */
1286                 }
1287                 else {
1288                     right = -biv;
1289                 }
1290             }
1291             /* historically undef()/0 gives a "Use of uninitialized value"
1292                warning before dieing, hence this test goes here.
1293                If it were immediately before the second SvIV_please, then
1294                DIE() would be invoked before left was even inspected, so
1295                no inpsection would give no warning.  */
1296             if (right == 0)
1297                 DIE(aTHX_ "Illegal division by zero");
1298
1299             if (left_non_neg) {
1300                 left = SvUVX(svl);
1301             }
1302             else {
1303                 const IV aiv = SvIVX(svl);
1304                 if (aiv >= 0) {
1305                     left = aiv;
1306                     left_non_neg = TRUE; /* effectively it's a UV now */
1307                 }
1308                 else {
1309                     left = -aiv;
1310                 }
1311             }
1312
1313             if (left >= right
1314 #ifdef SLOPPYDIVIDE
1315                 /* For sloppy divide we always attempt integer division.  */
1316 #else
1317                 /* Otherwise we only attempt it if either or both operands
1318                    would not be preserved by an NV.  If both fit in NVs
1319                    we fall through to the NV divide code below.  However,
1320                    as left >= right to ensure integer result here, we know that
1321                    we can skip the test on the right operand - right big
1322                    enough not to be preserved can't get here unless left is
1323                    also too big.  */
1324
1325                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1326 #endif
1327                 ) {
1328                 /* Integer division can't overflow, but it can be imprecise.  */
1329                 const UV result = left / right;
1330                 if (result * right == left) {
1331                     SP--; /* result is valid */
1332                     if (left_non_neg == right_non_neg) {
1333                         /* signs identical, result is positive.  */
1334                         SETu( result );
1335                         RETURN;
1336                     }
1337                     /* 2s complement assumption */
1338                     if (result <= (UV)IV_MIN)
1339                         SETi( -(IV)result );
1340                     else {
1341                         /* It's exact but too negative for IV. */
1342                         SETn( -(NV)result );
1343                     }
1344                     RETURN;
1345                 } /* tried integer divide but it was not an integer result */
1346             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1347         } /* left wasn't SvIOK */
1348     } /* right wasn't SvIOK */
1349 #endif /* PERL_TRY_UV_DIVIDE */
1350     {
1351         NV right = SvNV(svr);
1352         NV left  = SvNV(svl);
1353         (void)POPs;(void)POPs;
1354 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1355         if (! Perl_isnan(right) && right == 0.0)
1356 #else
1357         if (right == 0.0)
1358 #endif
1359             DIE(aTHX_ "Illegal division by zero");
1360         PUSHn( left / right );
1361         RETURN;
1362     }
1363 }
1364
1365 PP(pp_modulo)
1366 {
1367     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1368     {
1369         UV left  = 0;
1370         UV right = 0;
1371         bool left_neg = FALSE;
1372         bool right_neg = FALSE;
1373         bool use_double = FALSE;
1374         bool dright_valid = FALSE;
1375         NV dright = 0.0;
1376         NV dleft  = 0.0;
1377         SV * svl;
1378         SV * const svr = sv_2num(TOPs);
1379         SvIV_please(svr);
1380         if (SvIOK(svr)) {
1381             right_neg = !SvUOK(svr);
1382             if (!right_neg) {
1383                 right = SvUVX(svr);
1384             } else {
1385                 const IV biv = SvIVX(svr);
1386                 if (biv >= 0) {
1387                     right = biv;
1388                     right_neg = FALSE; /* effectively it's a UV now */
1389                 } else {
1390                     right = -biv;
1391                 }
1392             }
1393         }
1394         else {
1395             dright = SvNV(svr);
1396             right_neg = dright < 0;
1397             if (right_neg)
1398                 dright = -dright;
1399             if (dright < UV_MAX_P1) {
1400                 right = U_V(dright);
1401                 dright_valid = TRUE; /* In case we need to use double below.  */
1402             } else {
1403                 use_double = TRUE;
1404             }
1405         }
1406         sp--;
1407
1408         /* At this point use_double is only true if right is out of range for
1409            a UV.  In range NV has been rounded down to nearest UV and
1410            use_double false.  */
1411         svl = sv_2num(TOPs);
1412         SvIV_please(svl);
1413         if (!use_double && SvIOK(svl)) {
1414             if (SvIOK(svl)) {
1415                 left_neg = !SvUOK(svl);
1416                 if (!left_neg) {
1417                     left = SvUVX(svl);
1418                 } else {
1419                     const IV aiv = SvIVX(svl);
1420                     if (aiv >= 0) {
1421                         left = aiv;
1422                         left_neg = FALSE; /* effectively it's a UV now */
1423                     } else {
1424                         left = -aiv;
1425                     }
1426                 }
1427             }
1428         }
1429         else {
1430             dleft = SvNV(svl);
1431             left_neg = dleft < 0;
1432             if (left_neg)
1433                 dleft = -dleft;
1434
1435             /* This should be exactly the 5.6 behaviour - if left and right are
1436                both in range for UV then use U_V() rather than floor.  */
1437             if (!use_double) {
1438                 if (dleft < UV_MAX_P1) {
1439                     /* right was in range, so is dleft, so use UVs not double.
1440                      */
1441                     left = U_V(dleft);
1442                 }
1443                 /* left is out of range for UV, right was in range, so promote
1444                    right (back) to double.  */
1445                 else {
1446                     /* The +0.5 is used in 5.6 even though it is not strictly
1447                        consistent with the implicit +0 floor in the U_V()
1448                        inside the #if 1. */
1449                     dleft = Perl_floor(dleft + 0.5);
1450                     use_double = TRUE;
1451                     if (dright_valid)
1452                         dright = Perl_floor(dright + 0.5);
1453                     else
1454                         dright = right;
1455                 }
1456             }
1457         }
1458         sp--;
1459         if (use_double) {
1460             NV dans;
1461
1462             if (!dright)
1463                 DIE(aTHX_ "Illegal modulus zero");
1464
1465             dans = Perl_fmod(dleft, dright);
1466             if ((left_neg != right_neg) && dans)
1467                 dans = dright - dans;
1468             if (right_neg)
1469                 dans = -dans;
1470             sv_setnv(TARG, dans);
1471         }
1472         else {
1473             UV ans;
1474
1475             if (!right)
1476                 DIE(aTHX_ "Illegal modulus zero");
1477
1478             ans = left % right;
1479             if ((left_neg != right_neg) && ans)
1480                 ans = right - ans;
1481             if (right_neg) {
1482                 /* XXX may warn: unary minus operator applied to unsigned type */
1483                 /* could change -foo to be (~foo)+1 instead     */
1484                 if (ans <= ~((UV)IV_MAX)+1)
1485                     sv_setiv(TARG, ~ans+1);
1486                 else
1487                     sv_setnv(TARG, -(NV)ans);
1488             }
1489             else
1490                 sv_setuv(TARG, ans);
1491         }
1492         PUSHTARG;
1493         RETURN;
1494     }
1495 }
1496
1497 PP(pp_repeat)
1498 {
1499   dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1500   {
1501     register IV count;
1502     dPOPss;
1503     SvGETMAGIC(sv);
1504     if (SvIOKp(sv)) {
1505          if (SvUOK(sv)) {
1506               const UV uv = SvUV(sv);
1507               if (uv > IV_MAX)
1508                    count = IV_MAX; /* The best we can do? */
1509               else
1510                    count = uv;
1511          } else {
1512               const IV iv = SvIV(sv);
1513               if (iv < 0)
1514                    count = 0;
1515               else
1516                    count = iv;
1517          }
1518     }
1519     else if (SvNOKp(sv)) {
1520          const NV nv = SvNV(sv);
1521          if (nv < 0.0)
1522               count = 0;
1523          else
1524               count = (IV)nv;
1525     }
1526     else
1527          count = SvIV(sv);
1528     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1529         dMARK;
1530         static const char oom_list_extend[] = "Out of memory during list extend";
1531         const I32 items = SP - MARK;
1532         const I32 max = items * count;
1533
1534         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1535         /* Did the max computation overflow? */
1536         if (items > 0 && max > 0 && (max < items || max < count))
1537            Perl_croak(aTHX_ oom_list_extend);
1538         MEXTEND(MARK, max);
1539         if (count > 1) {
1540             while (SP > MARK) {
1541 #if 0
1542               /* This code was intended to fix 20010809.028:
1543
1544                  $x = 'abcd';
1545                  for (($x =~ /./g) x 2) {
1546                      print chop; # "abcdabcd" expected as output.
1547                  }
1548
1549                * but that change (#11635) broke this code:
1550
1551                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1552
1553                * I can't think of a better fix that doesn't introduce
1554                * an efficiency hit by copying the SVs. The stack isn't
1555                * refcounted, and mortalisation obviously doesn't
1556                * Do The Right Thing when the stack has more than
1557                * one pointer to the same mortal value.
1558                * .robin.
1559                */
1560                 if (*SP) {
1561                     *SP = sv_2mortal(newSVsv(*SP));
1562                     SvREADONLY_on(*SP);
1563                 }
1564 #else
1565                if (*SP)
1566                    SvTEMP_off((*SP));
1567 #endif
1568                 SP--;
1569             }
1570             MARK++;
1571             repeatcpy((char*)(MARK + items), (char*)MARK,
1572                 items * sizeof(const SV *), count - 1);
1573             SP += max;
1574         }
1575         else if (count <= 0)
1576             SP -= items;
1577     }
1578     else {      /* Note: mark already snarfed by pp_list */
1579         SV * const tmpstr = POPs;
1580         STRLEN len;
1581         bool isutf;
1582         static const char oom_string_extend[] =
1583           "Out of memory during string extend";
1584
1585         SvSetSV(TARG, tmpstr);
1586         SvPV_force(TARG, len);
1587         isutf = DO_UTF8(TARG);
1588         if (count != 1) {
1589             if (count < 1)
1590                 SvCUR_set(TARG, 0);
1591             else {
1592                 const STRLEN max = (UV)count * len;
1593                 if (len > MEM_SIZE_MAX / count)
1594                      Perl_croak(aTHX_ oom_string_extend);
1595                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1596                 SvGROW(TARG, max + 1);
1597                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1598                 SvCUR_set(TARG, SvCUR(TARG) * count);
1599             }
1600             *SvEND(TARG) = '\0';
1601         }
1602         if (isutf)
1603             (void)SvPOK_only_UTF8(TARG);
1604         else
1605             (void)SvPOK_only(TARG);
1606
1607         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1608             /* The parser saw this as a list repeat, and there
1609                are probably several items on the stack. But we're
1610                in scalar context, and there's no pp_list to save us
1611                now. So drop the rest of the items -- robin@kitsite.com
1612              */
1613             dMARK;
1614             SP = MARK;
1615         }
1616         PUSHTARG;
1617     }
1618     RETURN;
1619   }
1620 }
1621
1622 PP(pp_subtract)
1623 {
1624     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1625     tryAMAGICbin(subtr,opASSIGN);
1626     svl = sv_2num(TOPm1s);
1627     svr = sv_2num(TOPs);
1628     useleft = USE_LEFT(svl);
1629 #ifdef PERL_PRESERVE_IVUV
1630     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1631        "bad things" happen if you rely on signed integers wrapping.  */
1632     SvIV_please(svr);
1633     if (SvIOK(svr)) {
1634         /* Unless the left argument is integer in range we are going to have to
1635            use NV maths. Hence only attempt to coerce the right argument if
1636            we know the left is integer.  */
1637         register UV auv = 0;
1638         bool auvok = FALSE;
1639         bool a_valid = 0;
1640
1641         if (!useleft) {
1642             auv = 0;
1643             a_valid = auvok = 1;
1644             /* left operand is undef, treat as zero.  */
1645         } else {
1646             /* Left operand is defined, so is it IV? */
1647             SvIV_please(svl);
1648             if (SvIOK(svl)) {
1649                 if ((auvok = SvUOK(svl)))
1650                     auv = SvUVX(svl);
1651                 else {
1652                     register const IV aiv = SvIVX(svl);
1653                     if (aiv >= 0) {
1654                         auv = aiv;
1655                         auvok = 1;      /* Now acting as a sign flag.  */
1656                     } else { /* 2s complement assumption for IV_MIN */
1657                         auv = (UV)-aiv;
1658                     }
1659                 }
1660                 a_valid = 1;
1661             }
1662         }
1663         if (a_valid) {
1664             bool result_good = 0;
1665             UV result;
1666             register UV buv;
1667             bool buvok = SvUOK(svr);
1668
1669             if (buvok)
1670                 buv = SvUVX(svr);
1671             else {
1672                 register const IV biv = SvIVX(svr);
1673                 if (biv >= 0) {
1674                     buv = biv;
1675                     buvok = 1;
1676                 } else
1677                     buv = (UV)-biv;
1678             }
1679             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1680                else "IV" now, independent of how it came in.
1681                if a, b represents positive, A, B negative, a maps to -A etc
1682                a - b =>  (a - b)
1683                A - b => -(a + b)
1684                a - B =>  (a + b)
1685                A - B => -(a - b)
1686                all UV maths. negate result if A negative.
1687                subtract if signs same, add if signs differ. */
1688
1689             if (auvok ^ buvok) {
1690                 /* Signs differ.  */
1691                 result = auv + buv;
1692                 if (result >= auv)
1693                     result_good = 1;
1694             } else {
1695                 /* Signs same */
1696                 if (auv >= buv) {
1697                     result = auv - buv;
1698                     /* Must get smaller */
1699                     if (result <= auv)
1700                         result_good = 1;
1701                 } else {
1702                     result = buv - auv;
1703                     if (result <= buv) {
1704                         /* result really should be -(auv-buv). as its negation
1705                            of true value, need to swap our result flag  */
1706                         auvok = !auvok;
1707                         result_good = 1;
1708                     }
1709                 }
1710             }
1711             if (result_good) {
1712                 SP--;
1713                 if (auvok)
1714                     SETu( result );
1715                 else {
1716                     /* Negate result */
1717                     if (result <= (UV)IV_MIN)
1718                         SETi( -(IV)result );
1719                     else {
1720                         /* result valid, but out of range for IV.  */
1721                         SETn( -(NV)result );
1722                     }
1723                 }
1724                 RETURN;
1725             } /* Overflow, drop through to NVs.  */
1726         }
1727     }
1728 #endif
1729     {
1730         NV value = SvNV(svr);
1731         (void)POPs;
1732
1733         if (!useleft) {
1734             /* left operand is undef, treat as zero - value */
1735             SETn(-value);
1736             RETURN;
1737         }
1738         SETn( SvNV(svl) - value );
1739         RETURN;
1740     }
1741 }
1742
1743 PP(pp_left_shift)
1744 {
1745     dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1746     {
1747       const IV shift = POPi;
1748       if (PL_op->op_private & HINT_INTEGER) {
1749         const IV i = TOPi;
1750         SETi(i << shift);
1751       }
1752       else {
1753         const UV u = TOPu;
1754         SETu(u << shift);
1755       }
1756       RETURN;
1757     }
1758 }
1759
1760 PP(pp_right_shift)
1761 {
1762     dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1763     {
1764       const IV shift = POPi;
1765       if (PL_op->op_private & HINT_INTEGER) {
1766         const IV i = TOPi;
1767         SETi(i >> shift);
1768       }
1769       else {
1770         const UV u = TOPu;
1771         SETu(u >> shift);
1772       }
1773       RETURN;
1774     }
1775 }
1776
1777 PP(pp_lt)
1778 {
1779     dVAR; dSP; tryAMAGICbinSET(lt,0);
1780 #ifdef PERL_PRESERVE_IVUV
1781     SvIV_please(TOPs);
1782     if (SvIOK(TOPs)) {
1783         SvIV_please(TOPm1s);
1784         if (SvIOK(TOPm1s)) {
1785             bool auvok = SvUOK(TOPm1s);
1786             bool buvok = SvUOK(TOPs);
1787
1788             if (!auvok && !buvok) { /* ## IV < IV ## */
1789                 const IV aiv = SvIVX(TOPm1s);
1790                 const IV biv = SvIVX(TOPs);
1791
1792                 SP--;
1793                 SETs(boolSV(aiv < biv));
1794                 RETURN;
1795             }
1796             if (auvok && buvok) { /* ## UV < UV ## */
1797                 const UV auv = SvUVX(TOPm1s);
1798                 const UV buv = SvUVX(TOPs);
1799
1800                 SP--;
1801                 SETs(boolSV(auv < buv));
1802                 RETURN;
1803             }
1804             if (auvok) { /* ## UV < IV ## */
1805                 UV auv;
1806                 const IV biv = SvIVX(TOPs);
1807                 SP--;
1808                 if (biv < 0) {
1809                     /* As (a) is a UV, it's >=0, so it cannot be < */
1810                     SETs(&PL_sv_no);
1811                     RETURN;
1812                 }
1813                 auv = SvUVX(TOPs);
1814                 SETs(boolSV(auv < (UV)biv));
1815                 RETURN;
1816             }
1817             { /* ## IV < UV ## */
1818                 const IV aiv = SvIVX(TOPm1s);
1819                 UV buv;
1820
1821                 if (aiv < 0) {
1822                     /* As (b) is a UV, it's >=0, so it must be < */
1823                     SP--;
1824                     SETs(&PL_sv_yes);
1825                     RETURN;
1826                 }
1827                 buv = SvUVX(TOPs);
1828                 SP--;
1829                 SETs(boolSV((UV)aiv < buv));
1830                 RETURN;
1831             }
1832         }
1833     }
1834 #endif
1835 #ifndef NV_PRESERVES_UV
1836 #ifdef PERL_PRESERVE_IVUV
1837     else
1838 #endif
1839     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1840         SP--;
1841         SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1842         RETURN;
1843     }
1844 #endif
1845     {
1846 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1847       dPOPTOPnnrl;
1848       if (Perl_isnan(left) || Perl_isnan(right))
1849           RETSETNO;
1850       SETs(boolSV(left < right));
1851 #else
1852       dPOPnv;
1853       SETs(boolSV(TOPn < value));
1854 #endif
1855       RETURN;
1856     }
1857 }
1858
1859 PP(pp_gt)
1860 {
1861     dVAR; dSP; tryAMAGICbinSET(gt,0);
1862 #ifdef PERL_PRESERVE_IVUV
1863     SvIV_please(TOPs);
1864     if (SvIOK(TOPs)) {
1865         SvIV_please(TOPm1s);
1866         if (SvIOK(TOPm1s)) {
1867             bool auvok = SvUOK(TOPm1s);
1868             bool buvok = SvUOK(TOPs);
1869
1870             if (!auvok && !buvok) { /* ## IV > IV ## */
1871                 const IV aiv = SvIVX(TOPm1s);
1872                 const IV biv = SvIVX(TOPs);
1873
1874                 SP--;
1875                 SETs(boolSV(aiv > biv));
1876                 RETURN;
1877             }
1878             if (auvok && buvok) { /* ## UV > UV ## */
1879                 const UV auv = SvUVX(TOPm1s);
1880                 const UV buv = SvUVX(TOPs);
1881
1882                 SP--;
1883                 SETs(boolSV(auv > buv));
1884                 RETURN;
1885             }
1886             if (auvok) { /* ## UV > IV ## */
1887                 UV auv;
1888                 const IV biv = SvIVX(TOPs);
1889
1890                 SP--;
1891                 if (biv < 0) {
1892                     /* As (a) is a UV, it's >=0, so it must be > */
1893                     SETs(&PL_sv_yes);
1894                     RETURN;
1895                 }
1896                 auv = SvUVX(TOPs);
1897                 SETs(boolSV(auv > (UV)biv));
1898                 RETURN;
1899             }
1900             { /* ## IV > UV ## */
1901                 const IV aiv = SvIVX(TOPm1s);
1902                 UV buv;
1903
1904                 if (aiv < 0) {
1905                     /* As (b) is a UV, it's >=0, so it cannot be > */
1906                     SP--;
1907                     SETs(&PL_sv_no);
1908                     RETURN;
1909                 }
1910                 buv = SvUVX(TOPs);
1911                 SP--;
1912                 SETs(boolSV((UV)aiv > buv));
1913                 RETURN;
1914             }
1915         }
1916     }
1917 #endif
1918 #ifndef NV_PRESERVES_UV
1919 #ifdef PERL_PRESERVE_IVUV
1920     else
1921 #endif
1922     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1923         SP--;
1924         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1925         RETURN;
1926     }
1927 #endif
1928     {
1929 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1930       dPOPTOPnnrl;
1931       if (Perl_isnan(left) || Perl_isnan(right))
1932           RETSETNO;
1933       SETs(boolSV(left > right));
1934 #else
1935       dPOPnv;
1936       SETs(boolSV(TOPn > value));
1937 #endif
1938       RETURN;
1939     }
1940 }
1941
1942 PP(pp_le)
1943 {
1944     dVAR; dSP; tryAMAGICbinSET(le,0);
1945 #ifdef PERL_PRESERVE_IVUV
1946     SvIV_please(TOPs);
1947     if (SvIOK(TOPs)) {
1948         SvIV_please(TOPm1s);
1949         if (SvIOK(TOPm1s)) {
1950             bool auvok = SvUOK(TOPm1s);
1951             bool buvok = SvUOK(TOPs);
1952
1953             if (!auvok && !buvok) { /* ## IV <= IV ## */
1954                 const IV aiv = SvIVX(TOPm1s);
1955                 const IV biv = SvIVX(TOPs);
1956
1957                 SP--;
1958                 SETs(boolSV(aiv <= biv));
1959                 RETURN;
1960             }
1961             if (auvok && buvok) { /* ## UV <= UV ## */
1962                 UV auv = SvUVX(TOPm1s);
1963                 UV buv = SvUVX(TOPs);
1964
1965                 SP--;
1966                 SETs(boolSV(auv <= buv));
1967                 RETURN;
1968             }
1969             if (auvok) { /* ## UV <= IV ## */
1970                 UV auv;
1971                 const IV biv = SvIVX(TOPs);
1972
1973                 SP--;
1974                 if (biv < 0) {
1975                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1976                     SETs(&PL_sv_no);
1977                     RETURN;
1978                 }
1979                 auv = SvUVX(TOPs);
1980                 SETs(boolSV(auv <= (UV)biv));
1981                 RETURN;
1982             }
1983             { /* ## IV <= UV ## */
1984                 const IV aiv = SvIVX(TOPm1s);
1985                 UV buv;
1986
1987                 if (aiv < 0) {
1988                     /* As (b) is a UV, it's >=0, so a must be <= */
1989                     SP--;
1990                     SETs(&PL_sv_yes);
1991                     RETURN;
1992                 }
1993                 buv = SvUVX(TOPs);
1994                 SP--;
1995                 SETs(boolSV((UV)aiv <= buv));
1996                 RETURN;
1997             }
1998         }
1999     }
2000 #endif
2001 #ifndef NV_PRESERVES_UV
2002 #ifdef PERL_PRESERVE_IVUV
2003     else
2004 #endif
2005     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2006         SP--;
2007         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2008         RETURN;
2009     }
2010 #endif
2011     {
2012 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2013       dPOPTOPnnrl;
2014       if (Perl_isnan(left) || Perl_isnan(right))
2015           RETSETNO;
2016       SETs(boolSV(left <= right));
2017 #else
2018       dPOPnv;
2019       SETs(boolSV(TOPn <= value));
2020 #endif
2021       RETURN;
2022     }
2023 }
2024
2025 PP(pp_ge)
2026 {
2027     dVAR; dSP; tryAMAGICbinSET(ge,0);
2028 #ifdef PERL_PRESERVE_IVUV
2029     SvIV_please(TOPs);
2030     if (SvIOK(TOPs)) {
2031         SvIV_please(TOPm1s);
2032         if (SvIOK(TOPm1s)) {
2033             bool auvok = SvUOK(TOPm1s);
2034             bool buvok = SvUOK(TOPs);
2035
2036             if (!auvok && !buvok) { /* ## IV >= IV ## */
2037                 const IV aiv = SvIVX(TOPm1s);
2038                 const IV biv = SvIVX(TOPs);
2039
2040                 SP--;
2041                 SETs(boolSV(aiv >= biv));
2042                 RETURN;
2043             }
2044             if (auvok && buvok) { /* ## UV >= UV ## */
2045                 const UV auv = SvUVX(TOPm1s);
2046                 const UV buv = SvUVX(TOPs);
2047
2048                 SP--;
2049                 SETs(boolSV(auv >= buv));
2050                 RETURN;
2051             }
2052             if (auvok) { /* ## UV >= IV ## */
2053                 UV auv;
2054                 const IV biv = SvIVX(TOPs);
2055
2056                 SP--;
2057                 if (biv < 0) {
2058                     /* As (a) is a UV, it's >=0, so it must be >= */
2059                     SETs(&PL_sv_yes);
2060                     RETURN;
2061                 }
2062                 auv = SvUVX(TOPs);
2063                 SETs(boolSV(auv >= (UV)biv));
2064                 RETURN;
2065             }
2066             { /* ## IV >= UV ## */
2067                 const IV aiv = SvIVX(TOPm1s);
2068                 UV buv;
2069
2070                 if (aiv < 0) {
2071                     /* As (b) is a UV, it's >=0, so a cannot be >= */
2072                     SP--;
2073                     SETs(&PL_sv_no);
2074                     RETURN;
2075                 }
2076                 buv = SvUVX(TOPs);
2077                 SP--;
2078                 SETs(boolSV((UV)aiv >= buv));
2079                 RETURN;
2080             }
2081         }
2082     }
2083 #endif
2084 #ifndef NV_PRESERVES_UV
2085 #ifdef PERL_PRESERVE_IVUV
2086     else
2087 #endif
2088     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2089         SP--;
2090         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2091         RETURN;
2092     }
2093 #endif
2094     {
2095 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2096       dPOPTOPnnrl;
2097       if (Perl_isnan(left) || Perl_isnan(right))
2098           RETSETNO;
2099       SETs(boolSV(left >= right));
2100 #else
2101       dPOPnv;
2102       SETs(boolSV(TOPn >= value));
2103 #endif
2104       RETURN;
2105     }
2106 }
2107
2108 PP(pp_ne)
2109 {
2110     dVAR; dSP; tryAMAGICbinSET(ne,0);
2111 #ifndef NV_PRESERVES_UV
2112     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2113         SP--;
2114         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2115         RETURN;
2116     }
2117 #endif
2118 #ifdef PERL_PRESERVE_IVUV
2119     SvIV_please(TOPs);
2120     if (SvIOK(TOPs)) {
2121         SvIV_please(TOPm1s);
2122         if (SvIOK(TOPm1s)) {
2123             const bool auvok = SvUOK(TOPm1s);
2124             const bool buvok = SvUOK(TOPs);
2125
2126             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2127                 /* Casting IV to UV before comparison isn't going to matter
2128                    on 2s complement. On 1s complement or sign&magnitude
2129                    (if we have any of them) it could make negative zero
2130                    differ from normal zero. As I understand it. (Need to
2131                    check - is negative zero implementation defined behaviour
2132                    anyway?). NWC  */
2133                 const UV buv = SvUVX(POPs);
2134                 const UV auv = SvUVX(TOPs);
2135
2136                 SETs(boolSV(auv != buv));
2137                 RETURN;
2138             }
2139             {                   /* ## Mixed IV,UV ## */
2140                 IV iv;
2141                 UV uv;
2142
2143                 /* != is commutative so swap if needed (save code) */
2144                 if (auvok) {
2145                     /* swap. top of stack (b) is the iv */
2146                     iv = SvIVX(TOPs);
2147                     SP--;
2148                     if (iv < 0) {
2149                         /* As (a) is a UV, it's >0, so it cannot be == */
2150                         SETs(&PL_sv_yes);
2151                         RETURN;
2152                     }
2153                     uv = SvUVX(TOPs);
2154                 } else {
2155                     iv = SvIVX(TOPm1s);
2156                     SP--;
2157                     if (iv < 0) {
2158                         /* As (b) is a UV, it's >0, so it cannot be == */
2159                         SETs(&PL_sv_yes);
2160                         RETURN;
2161                     }
2162                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2163                 }
2164                 SETs(boolSV((UV)iv != uv));
2165                 RETURN;
2166             }
2167         }
2168     }
2169 #endif
2170     {
2171 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2172       dPOPTOPnnrl;
2173       if (Perl_isnan(left) || Perl_isnan(right))
2174           RETSETYES;
2175       SETs(boolSV(left != right));
2176 #else
2177       dPOPnv;
2178       SETs(boolSV(TOPn != value));
2179 #endif
2180       RETURN;
2181     }
2182 }
2183
2184 PP(pp_ncmp)
2185 {
2186     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2187 #ifndef NV_PRESERVES_UV
2188     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2189         const UV right = PTR2UV(SvRV(POPs));
2190         const UV left = PTR2UV(SvRV(TOPs));
2191         SETi((left > right) - (left < right));
2192         RETURN;
2193     }
2194 #endif
2195 #ifdef PERL_PRESERVE_IVUV
2196     /* Fortunately it seems NaN isn't IOK */
2197     SvIV_please(TOPs);
2198     if (SvIOK(TOPs)) {
2199         SvIV_please(TOPm1s);
2200         if (SvIOK(TOPm1s)) {
2201             const bool leftuvok = SvUOK(TOPm1s);
2202             const bool rightuvok = SvUOK(TOPs);
2203             I32 value;
2204             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2205                 const IV leftiv = SvIVX(TOPm1s);
2206                 const IV rightiv = SvIVX(TOPs);
2207
2208                 if (leftiv > rightiv)
2209                     value = 1;
2210                 else if (leftiv < rightiv)
2211                     value = -1;
2212                 else
2213                     value = 0;
2214             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2215                 const UV leftuv = SvUVX(TOPm1s);
2216                 const UV rightuv = SvUVX(TOPs);
2217
2218                 if (leftuv > rightuv)
2219                     value = 1;
2220                 else if (leftuv < rightuv)
2221                     value = -1;
2222                 else
2223                     value = 0;
2224             } else if (leftuvok) { /* ## UV <=> IV ## */
2225                 const IV rightiv = SvIVX(TOPs);
2226                 if (rightiv < 0) {
2227                     /* As (a) is a UV, it's >=0, so it cannot be < */
2228                     value = 1;
2229                 } else {
2230                     const UV leftuv = SvUVX(TOPm1s);
2231                     if (leftuv > (UV)rightiv) {
2232                         value = 1;
2233                     } else if (leftuv < (UV)rightiv) {
2234                         value = -1;
2235                     } else {
2236                         value = 0;
2237                     }
2238                 }
2239             } else { /* ## IV <=> UV ## */
2240                 const IV leftiv = SvIVX(TOPm1s);
2241                 if (leftiv < 0) {
2242                     /* As (b) is a UV, it's >=0, so it must be < */
2243                     value = -1;
2244                 } else {
2245                     const UV rightuv = SvUVX(TOPs);
2246                     if ((UV)leftiv > rightuv) {
2247                         value = 1;
2248                     } else if ((UV)leftiv < rightuv) {
2249                         value = -1;
2250                     } else {
2251                         value = 0;
2252                     }
2253                 }
2254             }
2255             SP--;
2256             SETi(value);
2257             RETURN;
2258         }
2259     }
2260 #endif
2261     {
2262       dPOPTOPnnrl;
2263       I32 value;
2264
2265 #ifdef Perl_isnan
2266       if (Perl_isnan(left) || Perl_isnan(right)) {
2267           SETs(&PL_sv_undef);
2268           RETURN;
2269        }
2270       value = (left > right) - (left < right);
2271 #else
2272       if (left == right)
2273         value = 0;
2274       else if (left < right)
2275         value = -1;
2276       else if (left > right)
2277         value = 1;
2278       else {
2279         SETs(&PL_sv_undef);
2280         RETURN;
2281       }
2282 #endif
2283       SETi(value);
2284       RETURN;
2285     }
2286 }
2287
2288 PP(pp_sle)
2289 {
2290     dVAR; dSP;
2291
2292     int amg_type = sle_amg;
2293     int multiplier = 1;
2294     int rhs = 1;
2295
2296     switch (PL_op->op_type) {
2297     case OP_SLT:
2298         amg_type = slt_amg;
2299         /* cmp < 0 */
2300         rhs = 0;
2301         break;
2302     case OP_SGT:
2303         amg_type = sgt_amg;
2304         /* cmp > 0 */
2305         multiplier = -1;
2306         rhs = 0;
2307         break;
2308     case OP_SGE:
2309         amg_type = sge_amg;
2310         /* cmp >= 0 */
2311         multiplier = -1;
2312         break;
2313     }
2314
2315     tryAMAGICbinSET_var(amg_type,0);
2316     {
2317       dPOPTOPssrl;
2318       const int cmp = (IN_LOCALE_RUNTIME
2319                  ? sv_cmp_locale(left, right)
2320                  : sv_cmp(left, right));
2321       SETs(boolSV(cmp * multiplier < rhs));
2322       RETURN;
2323     }
2324 }
2325
2326 PP(pp_seq)
2327 {
2328     dVAR; dSP; tryAMAGICbinSET(seq,0);
2329     {
2330       dPOPTOPssrl;
2331       SETs(boolSV(sv_eq(left, right)));
2332       RETURN;
2333     }
2334 }
2335
2336 PP(pp_sne)
2337 {
2338     dVAR; dSP; tryAMAGICbinSET(sne,0);
2339     {
2340       dPOPTOPssrl;
2341       SETs(boolSV(!sv_eq(left, right)));
2342       RETURN;
2343     }
2344 }
2345
2346 PP(pp_scmp)
2347 {
2348     dVAR; dSP; dTARGET;  tryAMAGICbin(scmp,0);
2349     {
2350       dPOPTOPssrl;
2351       const int cmp = (IN_LOCALE_RUNTIME
2352                  ? sv_cmp_locale(left, right)
2353                  : sv_cmp(left, right));
2354       SETi( cmp );
2355       RETURN;
2356     }
2357 }
2358
2359 PP(pp_bit_and)
2360 {
2361     dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2362     {
2363       dPOPTOPssrl;
2364       SvGETMAGIC(left);
2365       SvGETMAGIC(right);
2366       if (SvNIOKp(left) || SvNIOKp(right)) {
2367         if (PL_op->op_private & HINT_INTEGER) {
2368           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2369           SETi(i);
2370         }
2371         else {
2372           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2373           SETu(u);
2374         }
2375       }
2376       else {
2377         do_vop(PL_op->op_type, TARG, left, right);
2378         SETTARG;
2379       }
2380       RETURN;
2381     }
2382 }
2383
2384 PP(pp_bit_or)
2385 {
2386     dVAR; dSP; dATARGET;
2387     const int op_type = PL_op->op_type;
2388
2389     tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2390     {
2391       dPOPTOPssrl;
2392       SvGETMAGIC(left);
2393       SvGETMAGIC(right);
2394       if (SvNIOKp(left) || SvNIOKp(right)) {
2395         if (PL_op->op_private & HINT_INTEGER) {
2396           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2397           const IV r = SvIV_nomg(right);
2398           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2399           SETi(result);
2400         }
2401         else {
2402           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2403           const UV r = SvUV_nomg(right);
2404           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2405           SETu(result);
2406         }
2407       }
2408       else {
2409         do_vop(op_type, TARG, left, right);
2410         SETTARG;
2411       }
2412       RETURN;
2413     }
2414 }
2415
2416 PP(pp_negate)
2417 {
2418     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2419     {
2420         SV * const sv = sv_2num(TOPs);
2421         const int flags = SvFLAGS(sv);
2422         SvGETMAGIC(sv);
2423         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2424             /* It's publicly an integer, or privately an integer-not-float */
2425         oops_its_an_int:
2426             if (SvIsUV(sv)) {
2427                 if (SvIVX(sv) == IV_MIN) {
2428                     /* 2s complement assumption. */
2429                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2430                     RETURN;
2431                 }
2432                 else if (SvUVX(sv) <= IV_MAX) {
2433                     SETi(-SvIVX(sv));
2434                     RETURN;
2435                 }
2436             }
2437             else if (SvIVX(sv) != IV_MIN) {
2438                 SETi(-SvIVX(sv));
2439                 RETURN;
2440             }
2441 #ifdef PERL_PRESERVE_IVUV
2442             else {
2443                 SETu((UV)IV_MIN);
2444                 RETURN;
2445             }
2446 #endif
2447         }
2448         if (SvNIOKp(sv))
2449             SETn(-SvNV(sv));
2450         else if (SvPOKp(sv)) {
2451             STRLEN len;
2452             const char * const s = SvPV_const(sv, len);
2453             if (isIDFIRST(*s)) {
2454                 sv_setpvs(TARG, "-");
2455                 sv_catsv(TARG, sv);
2456             }
2457             else if (*s == '+' || *s == '-') {
2458                 sv_setsv(TARG, sv);
2459                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2460             }
2461             else if (DO_UTF8(sv)) {
2462                 SvIV_please(sv);
2463                 if (SvIOK(sv))
2464                     goto oops_its_an_int;
2465                 if (SvNOK(sv))
2466                     sv_setnv(TARG, -SvNV(sv));
2467                 else {
2468                     sv_setpvs(TARG, "-");
2469                     sv_catsv(TARG, sv);
2470                 }
2471             }
2472             else {
2473                 SvIV_please(sv);
2474                 if (SvIOK(sv))
2475                   goto oops_its_an_int;
2476                 sv_setnv(TARG, -SvNV(sv));
2477             }
2478             SETTARG;
2479         }
2480         else
2481             SETn(-SvNV(sv));
2482     }
2483     RETURN;
2484 }
2485
2486 PP(pp_not)
2487 {
2488     dVAR; dSP; tryAMAGICunSET_var(not_amg);
2489     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2490     return NORMAL;
2491 }
2492
2493 PP(pp_complement)
2494 {
2495     dVAR; dSP; dTARGET; tryAMAGICun_var(compl_amg);
2496     {
2497       dTOPss;
2498       SvGETMAGIC(sv);
2499       if (SvNIOKp(sv)) {
2500         if (PL_op->op_private & HINT_INTEGER) {
2501           const IV i = ~SvIV_nomg(sv);
2502           SETi(i);
2503         }
2504         else {
2505           const UV u = ~SvUV_nomg(sv);
2506           SETu(u);
2507         }
2508       }
2509       else {
2510         register U8 *tmps;
2511         register I32 anum;
2512         STRLEN len;
2513
2514         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2515         sv_setsv_nomg(TARG, sv);
2516         tmps = (U8*)SvPV_force(TARG, len);
2517         anum = len;
2518         if (SvUTF8(TARG)) {
2519           /* Calculate exact length, let's not estimate. */
2520           STRLEN targlen = 0;
2521           STRLEN l;
2522           UV nchar = 0;
2523           UV nwide = 0;
2524           U8 * const send = tmps + len;
2525           U8 * const origtmps = tmps;
2526           const UV utf8flags = UTF8_ALLOW_ANYUV;
2527
2528           while (tmps < send) {
2529             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2530             tmps += l;
2531             targlen += UNISKIP(~c);
2532             nchar++;
2533             if (c > 0xff)
2534                 nwide++;
2535           }
2536
2537           /* Now rewind strings and write them. */
2538           tmps = origtmps;
2539
2540           if (nwide) {
2541               U8 *result;
2542               U8 *p;
2543
2544               Newx(result, targlen + 1, U8);
2545               p = result;
2546               while (tmps < send) {
2547                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2548                   tmps += l;
2549                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2550               }
2551               *p = '\0';
2552               sv_usepvn_flags(TARG, (char*)result, targlen,
2553                               SV_HAS_TRAILING_NUL);
2554               SvUTF8_on(TARG);
2555           }
2556           else {
2557               U8 *result;
2558               U8 *p;
2559
2560               Newx(result, nchar + 1, U8);
2561               p = result;
2562               while (tmps < send) {
2563                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2564                   tmps += l;
2565                   *p++ = ~c;
2566               }
2567               *p = '\0';
2568               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2569               SvUTF8_off(TARG);
2570           }
2571           SETTARG;
2572           RETURN;
2573         }
2574 #ifdef LIBERAL
2575         {
2576             register long *tmpl;
2577             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2578                 *tmps = ~*tmps;
2579             tmpl = (long*)tmps;
2580             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2581                 *tmpl = ~*tmpl;
2582             tmps = (U8*)tmpl;
2583         }
2584 #endif
2585         for ( ; anum > 0; anum--, tmps++)
2586             *tmps = ~*tmps;
2587         SETTARG;
2588       }
2589       RETURN;
2590     }
2591 }
2592
2593 /* integer versions of some of the above */
2594
2595 PP(pp_i_multiply)
2596 {
2597     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2598     {
2599       dPOPTOPiirl;
2600       SETi( left * right );
2601       RETURN;
2602     }
2603 }
2604
2605 PP(pp_i_divide)
2606 {
2607     IV num;
2608     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2609     {
2610       dPOPiv;
2611       if (value == 0)
2612           DIE(aTHX_ "Illegal division by zero");
2613       num = POPi;
2614
2615       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2616       if (value == -1)
2617           value = - num;
2618       else
2619           value = num / value;
2620       PUSHi( value );
2621       RETURN;
2622     }
2623 }
2624
2625 #if defined(__GLIBC__) && IVSIZE == 8
2626 STATIC
2627 PP(pp_i_modulo_0)
2628 #else
2629 PP(pp_i_modulo)
2630 #endif
2631 {
2632      /* This is the vanilla old i_modulo. */
2633      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2634      {
2635           dPOPTOPiirl;
2636           if (!right)
2637                DIE(aTHX_ "Illegal modulus zero");
2638           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2639           if (right == -1)
2640               SETi( 0 );
2641           else
2642               SETi( left % right );
2643           RETURN;
2644      }
2645 }
2646
2647 #if defined(__GLIBC__) && IVSIZE == 8
2648 STATIC
2649 PP(pp_i_modulo_1)
2650
2651 {
2652      /* This is the i_modulo with the workaround for the _moddi3 bug
2653       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2654       * See below for pp_i_modulo. */
2655      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2656      {
2657           dPOPTOPiirl;
2658           if (!right)
2659                DIE(aTHX_ "Illegal modulus zero");
2660           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2661           if (right == -1)
2662               SETi( 0 );
2663           else
2664               SETi( left % PERL_ABS(right) );
2665           RETURN;
2666      }
2667 }
2668
2669 PP(pp_i_modulo)
2670 {
2671      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2672      {
2673           dPOPTOPiirl;
2674           if (!right)
2675                DIE(aTHX_ "Illegal modulus zero");
2676           /* The assumption is to use hereafter the old vanilla version... */
2677           PL_op->op_ppaddr =
2678                PL_ppaddr[OP_I_MODULO] =
2679                    Perl_pp_i_modulo_0;
2680           /* .. but if we have glibc, we might have a buggy _moddi3
2681            * (at least glicb 2.2.5 is known to have this bug), in other
2682            * words our integer modulus with negative quad as the second
2683            * argument might be broken.  Test for this and re-patch the
2684            * opcode dispatch table if that is the case, remembering to
2685            * also apply the workaround so that this first round works
2686            * right, too.  See [perl #9402] for more information. */
2687           {
2688                IV l =   3;
2689                IV r = -10;
2690                /* Cannot do this check with inlined IV constants since
2691                 * that seems to work correctly even with the buggy glibc. */
2692                if (l % r == -3) {
2693                     /* Yikes, we have the bug.
2694                      * Patch in the workaround version. */
2695                     PL_op->op_ppaddr =
2696                          PL_ppaddr[OP_I_MODULO] =
2697                              &Perl_pp_i_modulo_1;
2698                     /* Make certain we work right this time, too. */
2699                     right = PERL_ABS(right);
2700                }
2701           }
2702           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2703           if (right == -1)
2704               SETi( 0 );
2705           else
2706               SETi( left % right );
2707           RETURN;
2708      }
2709 }
2710 #endif
2711
2712 PP(pp_i_add)
2713 {
2714     dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2715     {
2716       dPOPTOPiirl_ul;
2717       SETi( left + right );
2718       RETURN;
2719     }
2720 }
2721
2722 PP(pp_i_subtract)
2723 {
2724     dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2725     {
2726       dPOPTOPiirl_ul;
2727       SETi( left - right );
2728       RETURN;
2729     }
2730 }
2731
2732 PP(pp_i_lt)
2733 {
2734     dVAR; dSP; tryAMAGICbinSET(lt,0);
2735     {
2736       dPOPTOPiirl;
2737       SETs(boolSV(left < right));
2738       RETURN;
2739     }
2740 }
2741
2742 PP(pp_i_gt)
2743 {
2744     dVAR; dSP; tryAMAGICbinSET(gt,0);
2745     {
2746       dPOPTOPiirl;
2747       SETs(boolSV(left > right));
2748       RETURN;
2749     }
2750 }
2751
2752 PP(pp_i_le)
2753 {
2754     dVAR; dSP; tryAMAGICbinSET(le,0);
2755     {
2756       dPOPTOPiirl;
2757       SETs(boolSV(left <= right));
2758       RETURN;
2759     }
2760 }
2761
2762 PP(pp_i_ge)
2763 {
2764     dVAR; dSP; tryAMAGICbinSET(ge,0);
2765     {
2766       dPOPTOPiirl;
2767       SETs(boolSV(left >= right));
2768       RETURN;
2769     }
2770 }
2771
2772 PP(pp_i_eq)
2773 {
2774     dVAR; dSP; tryAMAGICbinSET(eq,0);
2775     {
2776       dPOPTOPiirl;
2777       SETs(boolSV(left == right));
2778       RETURN;
2779     }
2780 }
2781
2782 PP(pp_i_ne)
2783 {
2784     dVAR; dSP; tryAMAGICbinSET(ne,0);
2785     {
2786       dPOPTOPiirl;
2787       SETs(boolSV(left != right));
2788       RETURN;
2789     }
2790 }
2791
2792 PP(pp_i_ncmp)
2793 {
2794     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2795     {
2796       dPOPTOPiirl;
2797       I32 value;
2798
2799       if (left > right)
2800         value = 1;
2801       else if (left < right)
2802         value = -1;
2803       else
2804         value = 0;
2805       SETi(value);
2806       RETURN;
2807     }
2808 }
2809
2810 PP(pp_i_negate)
2811 {
2812     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2813     SETi(-TOPi);
2814     RETURN;
2815 }
2816
2817 /* High falutin' math. */
2818
2819 PP(pp_atan2)
2820 {
2821     dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2822     {
2823       dPOPTOPnnrl;
2824       SETn(Perl_atan2(left, right));
2825       RETURN;
2826     }
2827 }
2828
2829 PP(pp_sin)
2830 {
2831     dVAR; dSP; dTARGET;
2832     int amg_type = sin_amg;
2833     const char *neg_report = NULL;
2834     NV (*func)(NV) = Perl_sin;
2835     const int op_type = PL_op->op_type;
2836
2837     switch (op_type) {
2838     case OP_COS:
2839         amg_type = cos_amg;
2840         func = Perl_cos;
2841         break;
2842     case OP_EXP:
2843         amg_type = exp_amg;
2844         func = Perl_exp;
2845         break;
2846     case OP_LOG:
2847         amg_type = log_amg;
2848         func = Perl_log;
2849         neg_report = "log";
2850         break;
2851     case OP_SQRT:
2852         amg_type = sqrt_amg;
2853         func = Perl_sqrt;
2854         neg_report = "sqrt";
2855         break;
2856     }
2857
2858     tryAMAGICun_var(amg_type);
2859     {
2860       const NV value = POPn;
2861       if (neg_report) {
2862           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2863               SET_NUMERIC_STANDARD();
2864               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2865           }
2866       }
2867       XPUSHn(func(value));
2868       RETURN;
2869     }
2870 }
2871
2872 /* Support Configure command-line overrides for rand() functions.
2873    After 5.005, perhaps we should replace this by Configure support
2874    for drand48(), random(), or rand().  For 5.005, though, maintain
2875    compatibility by calling rand() but allow the user to override it.
2876    See INSTALL for details.  --Andy Dougherty  15 July 1998
2877 */
2878 /* Now it's after 5.005, and Configure supports drand48() and random(),
2879    in addition to rand().  So the overrides should not be needed any more.
2880    --Jarkko Hietaniemi  27 September 1998
2881  */
2882
2883 #ifndef HAS_DRAND48_PROTO
2884 extern double drand48 (void);
2885 #endif
2886
2887 PP(pp_rand)
2888 {
2889     dVAR; dSP; dTARGET;
2890     NV value;
2891     if (MAXARG < 1)
2892         value = 1.0;
2893     else
2894         value = POPn;
2895     if (value == 0.0)
2896         value = 1.0;
2897     if (!PL_srand_called) {
2898         (void)seedDrand01((Rand_seed_t)seed());
2899         PL_srand_called = TRUE;
2900     }
2901     value *= Drand01();
2902     XPUSHn(value);
2903     RETURN;
2904 }
2905
2906 PP(pp_srand)
2907 {
2908     dVAR; dSP;
2909     const UV anum = (MAXARG < 1) ? seed() : POPu;
2910     (void)seedDrand01((Rand_seed_t)anum);
2911     PL_srand_called = TRUE;
2912     EXTEND(SP, 1);
2913     RETPUSHYES;
2914 }
2915
2916 PP(pp_int)
2917 {
2918     dVAR; dSP; dTARGET; tryAMAGICun(int);
2919     {
2920       SV * const sv = sv_2num(TOPs);
2921       const IV iv = SvIV(sv);
2922       /* XXX it's arguable that compiler casting to IV might be subtly
2923          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2924          else preferring IV has introduced a subtle behaviour change bug. OTOH
2925          relying on floating point to be accurate is a bug.  */
2926
2927       if (!SvOK(sv)) {
2928         SETu(0);
2929       }
2930       else if (SvIOK(sv)) {
2931         if (SvIsUV(sv))
2932             SETu(SvUV(sv));
2933         else
2934             SETi(iv);
2935       }
2936       else {
2937           const NV value = SvNV(sv);
2938           if (value >= 0.0) {
2939               if (value < (NV)UV_MAX + 0.5) {
2940                   SETu(U_V(value));
2941               } else {
2942                   SETn(Perl_floor(value));
2943               }
2944           }
2945           else {
2946               if (value > (NV)IV_MIN - 0.5) {
2947                   SETi(I_V(value));
2948               } else {
2949                   SETn(Perl_ceil(value));
2950               }
2951           }
2952       }
2953     }
2954     RETURN;
2955 }
2956
2957 PP(pp_abs)
2958 {
2959     dVAR; dSP; dTARGET; tryAMAGICun(abs);
2960     {
2961       SV * const sv = sv_2num(TOPs);
2962       /* This will cache the NV value if string isn't actually integer  */
2963       const IV iv = SvIV(sv);
2964
2965       if (!SvOK(sv)) {
2966         SETu(0);
2967       }
2968       else if (SvIOK(sv)) {
2969         /* IVX is precise  */
2970         if (SvIsUV(sv)) {
2971           SETu(SvUV(sv));       /* force it to be numeric only */
2972         } else {
2973           if (iv >= 0) {
2974             SETi(iv);
2975           } else {
2976             if (iv != IV_MIN) {
2977               SETi(-iv);
2978             } else {
2979               /* 2s complement assumption. Also, not really needed as
2980                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2981               SETu(IV_MIN);
2982             }
2983           }
2984         }
2985       } else{
2986         const NV value = SvNV(sv);
2987         if (value < 0.0)
2988           SETn(-value);
2989         else
2990           SETn(value);
2991       }
2992     }
2993     RETURN;
2994 }
2995
2996 PP(pp_oct)
2997 {
2998     dVAR; dSP; dTARGET;
2999     const char *tmps;
3000     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3001     STRLEN len;
3002     NV result_nv;
3003     UV result_uv;
3004     SV* const sv = POPs;
3005
3006     tmps = (SvPV_const(sv, len));
3007     if (DO_UTF8(sv)) {
3008          /* If Unicode, try to downgrade
3009           * If not possible, croak. */
3010          SV* const tsv = sv_2mortal(newSVsv(sv));
3011
3012          SvUTF8_on(tsv);
3013          sv_utf8_downgrade(tsv, FALSE);
3014          tmps = SvPV_const(tsv, len);
3015     }
3016     if (PL_op->op_type == OP_HEX)
3017         goto hex;
3018
3019     while (*tmps && len && isSPACE(*tmps))
3020         tmps++, len--;
3021     if (*tmps == '0')
3022         tmps++, len--;
3023     if (*tmps == 'x') {
3024     hex:
3025         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3026     }
3027     else if (*tmps == 'b')
3028         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3029     else
3030         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3031
3032     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3033         XPUSHn(result_nv);
3034     }
3035     else {
3036         XPUSHu(result_uv);
3037     }
3038     RETURN;
3039 }
3040
3041 /* String stuff. */
3042
3043 PP(pp_length)
3044 {
3045     dVAR; dSP; dTARGET;
3046     SV * const sv = TOPs;
3047
3048     if (SvGAMAGIC(sv)) {
3049         /* For an overloaded or magic scalar, we can't know in advance if
3050            it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3051            it likes to cache the length. Maybe that should be a documented
3052            feature of it.
3053         */
3054         STRLEN len;
3055         const char *const p
3056             = sv_2pv_flags(sv, &len,
3057                            SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3058
3059         if (!p)
3060             SETs(&PL_sv_undef);
3061         else if (DO_UTF8(sv)) {
3062             SETi(utf8_length((U8*)p, (U8*)p + len));
3063         }
3064         else
3065             SETi(len);
3066     } else if (SvOK(sv)) {
3067         /* Neither magic nor overloaded.  */
3068         if (DO_UTF8(sv))
3069             SETi(sv_len_utf8(sv));
3070         else
3071             SETi(sv_len(sv));
3072     } else {
3073         SETs(&PL_sv_undef);
3074     }
3075     RETURN;
3076 }
3077
3078 PP(pp_substr)
3079 {
3080     dVAR; dSP; dTARGET;
3081     SV *sv;
3082     STRLEN curlen;
3083     STRLEN utf8_curlen;
3084     SV *   pos_sv;
3085     IV     pos1_iv;
3086     int    pos1_is_uv;
3087     IV     pos2_iv;
3088     int    pos2_is_uv;
3089     SV *   len_sv;
3090     IV     len_iv = 0;
3091     int    len_is_uv = 1;
3092     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3093     const char *tmps;
3094     const IV arybase = CopARYBASE_get(PL_curcop);
3095     SV *repl_sv = NULL;
3096     const char *repl = NULL;
3097     STRLEN repl_len;
3098     const int num_args = PL_op->op_private & 7;
3099     bool repl_need_utf8_upgrade = FALSE;
3100     bool repl_is_utf8 = FALSE;
3101
3102     SvTAINTED_off(TARG);                        /* decontaminate */
3103     SvUTF8_off(TARG);                           /* decontaminate */
3104     if (num_args > 2) {
3105         if (num_args > 3) {
3106             repl_sv = POPs;
3107             repl = SvPV_const(repl_sv, repl_len);
3108             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3109         }
3110         len_sv    = POPs;
3111         len_iv    = SvIV(len_sv);
3112         len_is_uv = SvIOK_UV(len_sv);
3113     }
3114     pos_sv     = POPs;
3115     pos1_iv    = SvIV(pos_sv);
3116     pos1_is_uv = SvIOK_UV(pos_sv);
3117     sv = POPs;
3118     PUTBACK;
3119     if (repl_sv) {
3120         if (repl_is_utf8) {
3121             if (!DO_UTF8(sv))
3122                 sv_utf8_upgrade(sv);
3123         }
3124         else if (DO_UTF8(sv))
3125             repl_need_utf8_upgrade = TRUE;
3126     }
3127     tmps = SvPV_const(sv, curlen);
3128     if (DO_UTF8(sv)) {
3129         utf8_curlen = sv_len_utf8(sv);
3130         if (utf8_curlen == curlen)
3131             utf8_curlen = 0;
3132         else
3133             curlen = utf8_curlen;
3134     }
3135     else
3136         utf8_curlen = 0;
3137
3138     if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3139         UV pos1_uv = pos1_iv-arybase;
3140         /* Overflow can occur when $[ < 0 */
3141         if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3142             goto bound_fail;
3143         pos1_iv = pos1_uv;
3144         pos1_is_uv = 1;
3145     }
3146     else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3147         goto bound_fail;  /* $[=3; substr($_,2,...) */
3148     }
3149     else { /* pos < $[ */
3150         if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3151             pos1_iv = curlen;
3152             pos1_is_uv = 1;
3153         } else {
3154             if (curlen) {
3155                 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3156                 pos1_iv += curlen;
3157            }
3158         }
3159     }
3160     if (pos1_is_uv || pos1_iv > 0) {
3161         if ((UV)pos1_iv > curlen)
3162             goto bound_fail;
3163     }
3164
3165     if (num_args > 2) {
3166         if (!len_is_uv && len_iv < 0) {
3167             pos2_iv = curlen + len_iv;
3168             if (curlen)
3169                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3170             else
3171                 pos2_is_uv = 0;
3172         } else {  /* len_iv >= 0 */
3173             if (!pos1_is_uv && pos1_iv < 0) {
3174                 pos2_iv = pos1_iv + len_iv;
3175                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3176             } else {
3177                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3178                     pos2_iv = curlen;
3179                 else
3180                     pos2_iv = pos1_iv+len_iv;
3181                 pos2_is_uv = 1;
3182             }
3183         }
3184     }
3185     else {
3186         pos2_iv = curlen;
3187         pos2_is_uv = 1;
3188     }
3189
3190     if (!pos2_is_uv && pos2_iv < 0) {
3191         if (!pos1_is_uv && pos1_iv < 0)
3192             goto bound_fail;
3193         pos2_iv = 0;
3194     }
3195     else if (!pos1_is_uv && pos1_iv < 0)
3196         pos1_iv = 0;
3197
3198     if ((UV)pos2_iv < (UV)pos1_iv)
3199         pos2_iv = pos1_iv;
3200     if ((UV)pos2_iv > curlen)
3201         pos2_iv = curlen;
3202
3203     {
3204         /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3205         const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3206         const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3207         STRLEN byte_len = len;
3208         STRLEN byte_pos = utf8_curlen
3209             ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3210
3211         tmps += byte_pos;
3212         /* we either return a PV or an LV. If the TARG hasn't been used
3213          * before, or is of that type, reuse it; otherwise use a mortal
3214          * instead. Note that LVs can have an extended lifetime, so also
3215          * dont reuse if refcount > 1 (bug #20933) */
3216         if (SvTYPE(TARG) > SVt_NULL) {
3217             if ( (SvTYPE(TARG) == SVt_PVLV)
3218                     ? (!lvalue || SvREFCNT(TARG) > 1)
3219                     : lvalue)
3220             {
3221                 TARG = sv_newmortal();
3222             }
3223         }
3224
3225         sv_setpvn(TARG, tmps, byte_len);
3226 #ifdef USE_LOCALE_COLLATE
3227         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3228 #endif
3229         if (utf8_curlen)
3230             SvUTF8_on(TARG);
3231         if (repl) {
3232             SV* repl_sv_copy = NULL;
3233
3234             if (repl_need_utf8_upgrade) {
3235                 repl_sv_copy = newSVsv(repl_sv);
3236                 sv_utf8_upgrade(repl_sv_copy);
3237                 repl = SvPV_const(repl_sv_copy, repl_len);
3238                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3239             }
3240             if (!SvOK(sv))
3241                 sv_setpvs(sv, "");
3242             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3243             if (repl_is_utf8)
3244                 SvUTF8_on(sv);
3245             SvREFCNT_dec(repl_sv_copy);
3246         }
3247         else if (lvalue) {              /* it's an lvalue! */
3248             if (!SvGMAGICAL(sv)) {
3249                 if (SvROK(sv)) {
3250                     SvPV_force_nolen(sv);
3251                     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3252                                    "Attempt to use reference as lvalue in substr");
3253                 }
3254                 if (isGV_with_GP(sv))
3255                     SvPV_force_nolen(sv);
3256                 else if (SvOK(sv))      /* is it defined ? */
3257                     (void)SvPOK_only_UTF8(sv);
3258                 else
3259                     sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3260             }
3261
3262             if (SvTYPE(TARG) < SVt_PVLV) {
3263                 sv_upgrade(TARG, SVt_PVLV);
3264                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3265             }
3266
3267             LvTYPE(TARG) = 'x';
3268             if (LvTARG(TARG) != sv) {
3269                 SvREFCNT_dec(LvTARG(TARG));
3270                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3271             }
3272             LvTARGOFF(TARG) = pos;
3273             LvTARGLEN(TARG) = len;
3274         }
3275     }
3276     SPAGAIN;
3277     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3278     RETURN;
3279
3280 bound_fail:
3281     if (lvalue || repl)
3282         Perl_croak(aTHX_ "substr outside of string");
3283     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3284     RETPUSHUNDEF;
3285 }
3286
3287 PP(pp_vec)
3288 {
3289     dVAR; dSP; dTARGET;
3290     register const IV size   = POPi;
3291     register const IV offset = POPi;
3292     register SV * const src = POPs;
3293     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3294
3295     SvTAINTED_off(TARG);                /* decontaminate */
3296     if (lvalue) {                       /* it's an lvalue! */
3297         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3298             TARG = sv_newmortal();
3299         if (SvTYPE(TARG) < SVt_PVLV) {
3300             sv_upgrade(TARG, SVt_PVLV);
3301             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3302         }
3303         LvTYPE(TARG) = 'v';
3304         if (LvTARG(TARG) != src) {
3305             SvREFCNT_dec(LvTARG(TARG));
3306             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3307         }
3308         LvTARGOFF(TARG) = offset;
3309         LvTARGLEN(TARG) = size;
3310     }
3311
3312     sv_setuv(TARG, do_vecget(src, offset, size));
3313     PUSHs(TARG);
3314     RETURN;
3315 }
3316
3317 PP(pp_index)
3318 {
3319     dVAR; dSP; dTARGET;
3320     SV *big;
3321     SV *little;
3322     SV *temp = NULL;
3323     STRLEN biglen;
3324     STRLEN llen = 0;
3325     I32 offset;
3326     I32 retval;
3327     const char *big_p;
3328     const char *little_p;
3329     const I32 arybase = CopARYBASE_get(PL_curcop);
3330     bool big_utf8;
3331     bool little_utf8;
3332     const bool is_index = PL_op->op_type == OP_INDEX;
3333
3334     if (MAXARG >= 3) {
3335         /* arybase is in characters, like offset, so combine prior to the
3336            UTF-8 to bytes calculation.  */
3337         offset = POPi - arybase;
3338     }
3339     little = POPs;
3340     big = POPs;
3341     big_p = SvPV_const(big, biglen);
3342     little_p = SvPV_const(little, llen);
3343
3344     big_utf8 = DO_UTF8(big);
3345     little_utf8 = DO_UTF8(little);
3346     if (big_utf8 ^ little_utf8) {
3347         /* One needs to be upgraded.  */
3348         if (little_utf8 && !PL_encoding) {
3349             /* Well, maybe instead we might be able to downgrade the small
3350                string?  */
3351             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3352                                                      &little_utf8);
3353             if (little_utf8) {
3354                 /* If the large string is ISO-8859-1, and it's not possible to
3355                    convert the small string to ISO-8859-1, then there is no
3356                    way that it could be found anywhere by index.  */
3357                 retval = -1;
3358                 goto fail;
3359             }
3360
3361             /* At this point, pv is a malloc()ed string. So donate it to temp
3362                to ensure it will get free()d  */
3363             little = temp = newSV(0);
3364             sv_usepvn(temp, pv, llen);
3365             little_p = SvPVX(little);
3366         } else {
3367             temp = little_utf8
3368                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3369
3370             if (PL_encoding) {
3371                 sv_recode_to_utf8(temp, PL_encoding);
3372             } else {
3373                 sv_utf8_upgrade(temp);
3374             }
3375             if (little_utf8) {
3376                 big = temp;
3377                 big_utf8 = TRUE;
3378                 big_p = SvPV_const(big, biglen);
3379             } else {
3380                 little = temp;
3381                 little_p = SvPV_const(little, llen);
3382             }
3383         }
3384     }
3385     if (SvGAMAGIC(big)) {
3386         /* Life just becomes a lot easier if I use a temporary here.
3387            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3388            will trigger magic and overloading again, as will fbm_instr()
3389         */
3390         big = newSVpvn_flags(big_p, biglen,
3391                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3392         big_p = SvPVX(big);
3393     }
3394     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3395         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3396            warn on undef, and we've already triggered a warning with the
3397            SvPV_const some lines above. We can't remove that, as we need to
3398            call some SvPV to trigger overloading early and find out if the
3399            string is UTF-8.
3400            This is all getting to messy. The API isn't quite clean enough,
3401            because data access has side effects.
3402         */
3403         little = newSVpvn_flags(little_p, llen,
3404                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3405         little_p = SvPVX(little);
3406     }
3407
3408     if (MAXARG < 3)
3409         offset = is_index ? 0 : biglen;
3410     else {
3411         if (big_utf8 && offset > 0)
3412             sv_pos_u2b(big, &offset, 0);
3413         if (!is_index)
3414             offset += llen;
3415     }
3416     if (offset < 0)
3417         offset = 0;
3418     else if (offset > (I32)biglen)
3419         offset = biglen;
3420     if (!(little_p = is_index
3421           ? fbm_instr((unsigned char*)big_p + offset,
3422                       (unsigned char*)big_p + biglen, little, 0)
3423           : rninstr(big_p,  big_p  + offset,
3424                     little_p, little_p + llen)))
3425         retval = -1;
3426     else {
3427         retval = little_p - big_p;
3428         if (retval > 0 && big_utf8)
3429             sv_pos_b2u(big, &retval);
3430     }
3431     SvREFCNT_dec(temp);
3432  fail:
3433     PUSHi(retval + arybase);
3434     RETURN;
3435 }
3436
3437 PP(pp_sprintf)
3438 {
3439     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3440     if (SvTAINTED(MARK[1]))
3441         TAINT_PROPER("sprintf");
3442     SvTAINTED_off(TARG);
3443     do_sprintf(TARG, SP-MARK, MARK+1);
3444     TAINT_IF(SvTAINTED(TARG));
3445     SP = ORIGMARK;
3446     PUSHTARG;
3447     RETURN;
3448 }
3449
3450 PP(pp_ord)
3451 {
3452     dVAR; dSP; dTARGET;
3453
3454     SV *argsv = POPs;
3455     STRLEN len;
3456     const U8 *s = (U8*)SvPV_const(argsv, len);
3457
3458     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3459         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3460         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3461         argsv = tmpsv;
3462     }
3463
3464     XPUSHu(DO_UTF8(argsv) ?
3465            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3466            (UV)(*s & 0xff));
3467
3468     RETURN;
3469 }
3470
3471 PP(pp_chr)
3472 {
3473     dVAR; dSP; dTARGET;
3474     char *tmps;
3475     UV value;
3476
3477     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3478          ||
3479          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3480         if (IN_BYTES) {
3481             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3482         } else {
3483             (void) POPs; /* Ignore the argument value. */
3484             value = UNICODE_REPLACEMENT;
3485         }
3486     } else {
3487         value = POPu;
3488     }
3489
3490     SvUPGRADE(TARG,SVt_PV);
3491
3492     if (value > 255 && !IN_BYTES) {
3493         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3494         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3495         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3496         *tmps = '\0';
3497         (void)SvPOK_only(TARG);
3498         SvUTF8_on(TARG);
3499         XPUSHs(TARG);
3500         RETURN;
3501     }
3502
3503     SvGROW(TARG,2);
3504     SvCUR_set(TARG, 1);
3505     tmps = SvPVX(TARG);
3506     *tmps++ = (char)value;
3507     *tmps = '\0';
3508     (void)SvPOK_only(TARG);
3509
3510     if (PL_encoding && !IN_BYTES) {
3511         sv_recode_to_utf8(TARG, PL_encoding);
3512         tmps = SvPVX(TARG);
3513         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3514             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3515             SvGROW(TARG, 2);
3516             tmps = SvPVX(TARG);
3517             SvCUR_set(TARG, 1);
3518             *tmps++ = (char)value;
3519             *tmps = '\0';
3520             SvUTF8_off(TARG);
3521         }
3522     }
3523
3524     XPUSHs(TARG);
3525     RETURN;
3526 }
3527
3528 PP(pp_crypt)
3529 {
3530 #ifdef HAS_CRYPT
3531     dVAR; dSP; dTARGET;
3532     dPOPTOPssrl;
3533     STRLEN len;
3534     const char *tmps = SvPV_const(left, len);
3535
3536     if (DO_UTF8(left)) {
3537          /* If Unicode, try to downgrade.
3538           * If not possible, croak.
3539           * Yes, we made this up.  */
3540          SV* const tsv = sv_2mortal(newSVsv(left));
3541
3542          SvUTF8_on(tsv);
3543          sv_utf8_downgrade(tsv, FALSE);
3544          tmps = SvPV_const(tsv, len);
3545     }
3546 #   ifdef USE_ITHREADS
3547 #     ifdef HAS_CRYPT_R
3548     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3549       /* This should be threadsafe because in ithreads there is only
3550        * one thread per interpreter.  If this would not be true,
3551        * we would need a mutex to protect this malloc. */
3552         PL_reentrant_buffer->_crypt_struct_buffer =
3553           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3554 #if defined(__GLIBC__) || defined(__EMX__)
3555         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3556             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3557             /* work around glibc-2.2.5 bug */
3558             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3559         }
3560 #endif
3561     }
3562 #     endif /* HAS_CRYPT_R */
3563 #   endif /* USE_ITHREADS */
3564 #   ifdef FCRYPT
3565     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3566 #   else
3567     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3568 #   endif
3569     SETTARG;
3570     RETURN;
3571 #else
3572     DIE(aTHX_
3573       "The crypt() function is unimplemented due to excessive paranoia.");
3574     return NORMAL;
3575 #endif
3576 }
3577
3578 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3579  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3580
3581 /* Both the characters below can be stored in two UTF-8 bytes.  In UTF-8 the max
3582  * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3583  * See http://www.unicode.org/unicode/reports/tr16 */
3584 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178    /* Also is title case */
3585 #define GREEK_CAPITAL_LETTER_MU 0x039C  /* Upper and title case of MICRON */
3586
3587 /* Below are several macros that generate code */
3588 /* Generates code to store a unicode codepoint c that is known to occupy
3589  * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3590 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c)                                    \
3591     STMT_START {                                                            \
3592         *(p) = UTF8_TWO_BYTE_HI(c);                                         \
3593         *((p)+1) = UTF8_TWO_BYTE_LO(c);                                     \
3594     } STMT_END
3595
3596 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3597  * available byte after the two bytes */
3598 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c)                                      \
3599     STMT_START {                                                            \
3600         *(p)++ = UTF8_TWO_BYTE_HI(c);                                       \
3601         *((p)++) = UTF8_TWO_BYTE_LO(c);                                     \
3602     } STMT_END
3603
3604 /* Generates code to store the upper case of latin1 character l which is known
3605  * to have its upper case be non-latin1 into the two bytes p and p+1.  There
3606  * are only two characters that fit this description, and this macro knows
3607  * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3608  * bytes */
3609 #define STORE_NON_LATIN1_UC(p, l)                                           \
3610 STMT_START {                                                                \
3611     if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3612         STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);  \
3613     } else { /* Must be the following letter */                                                             \
3614         STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU);           \
3615     }                                                                       \
3616 } STMT_END
3617
3618 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3619  * after the character stored */
3620 #define CAT_NON_LATIN1_UC(p, l)                                             \
3621 STMT_START {                                                                \
3622     if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3623         CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);    \
3624     } else {                                                                \
3625         CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU);             \
3626     }                                                                       \
3627 } STMT_END
3628
3629 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3630  * case of l into p and p+1.  u must be the result of toUPPER_LATIN1_MOD(l),
3631  * and must require two bytes to store it.  Advances p to point to the next
3632  * available position */
3633 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u)                                 \
3634 STMT_START {                                                                \
3635     if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3636         CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3637     } else if (l == LATIN_SMALL_LETTER_SHARP_S) {                           \
3638         *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */                \
3639     } else {/* else is one of the other two special cases */                \
3640         CAT_NON_LATIN1_UC((p), (l));                                        \
3641     }                                                                       \
3642 } STMT_END
3643
3644 PP(pp_ucfirst)
3645 {
3646     /* Actually is both lcfirst() and ucfirst().  Only the first character
3647      * changes.  This means that possibly we can change in-place, ie., just
3648      * take the source and change that one character and store it back, but not
3649      * if read-only etc, or if the length changes */
3650
3651     dVAR;
3652     dSP;
3653     SV *source = TOPs;
3654     STRLEN slen; /* slen is the byte length of the whole SV. */
3655     STRLEN need;
3656     SV *dest;
3657     bool inplace;   /* ? Convert first char only, in-place */
3658     bool doing_utf8 = FALSE;               /* ? using utf8 */
3659     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3660     const int op_type = PL_op->op_type;
3661     const U8 *s;
3662     U8 *d;
3663     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3664     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3665                      * stored as UTF-8 at s. */
3666     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3667                      * lowercased) character stored in tmpbuf.  May be either
3668                      * UTF-8 or not, but in either case is the number of bytes */
3669
3670     SvGETMAGIC(source);
3671     if (SvOK(source)) {
3672         s = (const U8*)SvPV_nomg_const(source, slen);
3673     } else {
3674         if (ckWARN(WARN_UNINITIALIZED))
3675             report_uninit(source);
3676         s = (const U8*)"";
3677         slen = 0;
3678     }
3679
3680     /* We may be able to get away with changing only the first character, in
3681      * place, but not if read-only, etc.  Later we may discover more reasons to
3682      * not convert in-place. */
3683     inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3684
3685     /* First calculate what the changed first character should be.  This affects
3686      * whether we can just swap it out, leaving the rest of the string unchanged,
3687      * or even if have to convert the dest to UTF-8 when the source isn't */
3688
3689     if (! slen) {   /* If empty */
3690         need = 1; /* still need a trailing NUL */
3691     }
3692     else if (DO_UTF8(source)) { /* Is the source utf8? */
3693         doing_utf8 = TRUE;
3694
3695 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3696  * and doesn't allow for the user to specify their own.  When code is added to
3697  * detect if there is a user-defined mapping in force here, and if so to use
3698  * that, then the code below can be compiled.  The detection would be a good
3699  * thing anyway, as currently the user-defined mappings only work on utf8
3700  * strings, and thus depend on the chosen internal storage method, which is a
3701  * bad thing */
3702 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3703         if (UTF8_IS_INVARIANT(*s)) {
3704
3705             /* An invariant source character is either ASCII or, in EBCDIC, an
3706              * ASCII equivalent or a caseless C1 control.  In both these cases,
3707              * the lower and upper cases of any character are also invariants
3708              * (and title case is the same as upper case).  So it is safe to
3709              * use the simple case change macros which avoid the overhead of
3710              * the general functions.  Note that if perl were to be extended to
3711              * do locale handling in UTF-8 strings, this wouldn't be true in,
3712              * for example, Lithuanian or Turkic.  */
3713             *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3714             tculen = ulen = 1;
3715             need = slen + 1;
3716         }
3717         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3718             U8 chr;
3719
3720             /* Similarly, if the source character isn't invariant but is in the
3721              * latin1 range (or EBCDIC equivalent thereof), we have the case
3722              * changes compiled into perl, and can avoid the overhead of the
3723              * general functions.  In this range, the characters are stored as
3724              * two UTF-8 bytes, and it so happens that any changed-case version
3725              * is also two bytes (in both ASCIIish and EBCDIC machines). */
3726             tculen = ulen = 2;
3727             need = slen + 1;
3728
3729             /* Convert the two source bytes to a single Unicode code point
3730              * value, change case and save for below */
3731             chr = UTF8_ACCUMULATE(*s, *(s+1));
3732             if (op_type == OP_LCFIRST) {    /* lower casing is easy */
3733                 U8 lower = toLOWER_LATIN1(chr);
3734                 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3735             }
3736             else {      /* ucfirst */
3737                 U8 upper = toUPPER_LATIN1_MOD(chr);
3738
3739                 /* Most of the latin1 range characters are well-behaved.  Their
3740                  * title and upper cases are the same, and are also in the
3741                  * latin1 range.  The macro above returns their upper (hence
3742                  * title) case, and all that need be done is to save the result
3743                  * for below.  However, several characters are problematic, and
3744                  * have to be handled specially.  The MOD in the macro name
3745                  * above means that these tricky characters all get mapped to
3746                  * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3747                  * This mapping saves some tests for the majority of the
3748                  * characters */
3749
3750                 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3751
3752                     /* Not tricky.  Just save it. */
3753                     STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3754                 }
3755                 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3756
3757                     /* This one is tricky because it is two characters long,
3758                      * though the UTF-8 is still two bytes, so the stored
3759                      * length doesn't change */
3760                     *tmpbuf = 'S';  /* The UTF-8 is 'Ss' */
3761                     *(tmpbuf + 1) = 's';
3762                 }
3763                 else {
3764
3765                     /* The other two have their title and upper cases the same,
3766                      * but are tricky because the changed-case characters
3767                      * aren't in the latin1 range.  They, however, do fit into
3768                      * two UTF-8 bytes */
3769                     STORE_NON_LATIN1_UC(tmpbuf, chr);
3770                 }
3771             }
3772         }
3773         else {
3774 #endif  /* end of dont want to break user-defined casing */
3775
3776             /* Here, can't short-cut the general case */
3777
3778             utf8_to_uvchr(s, &ulen);
3779             if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3780             else toLOWER_utf8(s, tmpbuf, &tculen);
3781
3782             /* we can't do in-place if the length changes.  */
3783             if (ulen != tculen) inplace = FALSE;
3784             need = slen + 1 - ulen + tculen;
3785 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3786         }
3787 #endif
3788     }
3789     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3790             * latin1 is treated as caseless.  Note that a locale takes
3791             * precedence */
3792         tculen = 1;     /* Most characters will require one byte, but this will
3793                          * need to be overridden for the tricky ones */
3794         need = slen + 1;
3795
3796         if (op_type == OP_LCFIRST) {
3797
3798             /* lower case the first letter: no trickiness for any character */
3799             *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3800                         ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3801         }
3802         /* is ucfirst() */
3803         else if (IN_LOCALE_RUNTIME) {
3804             *tmpbuf = toUPPER_LC(*s);   /* This would be a bug if any locales
3805                                          * have upper and title case different
3806                                          */
3807         }
3808         else if (! IN_UNI_8_BIT) {
3809             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3810                                          * on EBCDIC machines whatever the
3811                                          * native function does */
3812         }
3813         else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3814             *tmpbuf = toUPPER_LATIN1_MOD(*s);
3815
3816             /* tmpbuf now has the correct title case for all latin1 characters
3817              * except for the several ones that have tricky handling.  All
3818              * of these are mapped by the MOD to the letter below. */
3819             if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3820
3821                 /* The length is going to change, with all three of these, so
3822                  * can't replace just the first character */
3823                 inplace = FALSE;
3824
3825                 /* We use the original to distinguish between these tricky
3826                  * cases */
3827                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3828                     /* Two character title case 'Ss', but can remain non-UTF-8 */
3829                     need = slen + 2;
3830                     *tmpbuf = 'S';
3831                     *(tmpbuf + 1) = 's';   /* Assert: length(tmpbuf) >= 2 */
3832                     tculen = 2;
3833                 }
3834                 else {
3835
3836                     /* The other two tricky ones have their title case outside
3837                      * latin1.  It is the same as their upper case. */
3838                     doing_utf8 = TRUE;
3839                     STORE_NON_LATIN1_UC(tmpbuf, *s);
3840
3841                     /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3842                      * and their upper cases is 2. */
3843                     tculen = ulen = 2;
3844
3845                     /* The entire result will have to be in UTF-8.  Assume worst
3846                      * case sizing in conversion. (all latin1 characters occupy
3847                      * at most two bytes in utf8) */
3848                     convert_source_to_utf8 = TRUE;
3849                     need = slen * 2 + 1;
3850                 }
3851             } /* End of is one of the three special chars */
3852         } /* End of use Unicode (Latin1) semantics */
3853     } /* End of changing the case of the first character */
3854
3855     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3856      * generate the result */
3857     if (inplace) {
3858
3859         /* We can convert in place.  This means we change just the first
3860          * character without disturbing the rest; no need to grow */
3861         dest = source;
3862         s = d = (U8*)SvPV_force_nomg(source, slen);
3863     } else {
3864         dTARGET;
3865
3866         dest = TARG;
3867
3868         /* Here, we can't convert in place; we earlier calculated how much
3869          * space we will need, so grow to accommodate that */
3870         SvUPGRADE(dest, SVt_PV);
3871         d = (U8*)SvGROW(dest, need);
3872         (void)SvPOK_only(dest);
3873
3874         SETs(dest);
3875     }
3876
3877     if (doing_utf8) {
3878         if (! inplace) {
3879             if (! convert_source_to_utf8) {
3880
3881                 /* Here  both source and dest are in UTF-8, but have to create
3882                  * the entire output.  We initialize the result to be the
3883                  * title/lower cased first character, and then append the rest
3884                  * of the string. */
3885                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3886                 if (slen > ulen) {
3887                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3888                 }
3889             }
3890             else {
3891                 const U8 *const send = s + slen;
3892
3893                 /* Here the dest needs to be in UTF-8, but the source isn't,
3894                  * except we earlier UTF-8'd the first character of the source
3895                  * into tmpbuf.  First put that into dest, and then append the
3896                  * rest of the source, converting it to UTF-8 as we go. */
3897
3898                 /* Assert tculen is 2 here because the only two characters that
3899                  * get to this part of the code have 2-byte UTF-8 equivalents */
3900                 *d++ = *tmpbuf;
3901                 *d++ = *(tmpbuf + 1);
3902                 s++;    /* We have just processed the 1st char */
3903
3904                 for (; s < send; s++) {
3905                     d = uvchr_to_utf8(d, *s);
3906                 }
3907                 *d = '\0';
3908                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3909             }
3910             SvUTF8_on(dest);
3911         }
3912         else {   /* in-place UTF-8.  Just overwrite the first character */
3913             Copy(tmpbuf, d, tculen, U8);
3914             SvCUR_set(dest, need - 1);
3915         }
3916     }
3917     else {  /* Neither source nor dest are in or need to be UTF-8 */
3918         if (slen) {
3919             if (IN_LOCALE_RUNTIME) {
3920                 TAINT;
3921                 SvTAINTED_on(dest);
3922             }
3923             if (inplace) {  /* in-place, only need to change the 1st char */
3924                 *d = *tmpbuf;
3925             }
3926             else {      /* Not in-place */
3927
3928                 /* Copy the case-changed character(s) from tmpbuf */
3929                 Copy(tmpbuf, d, tculen, U8);
3930                 d += tculen - 1; /* Code below expects d to point to final
3931                                   * character stored */
3932             }
3933         }
3934         else {  /* empty source */
3935             /* See bug #39028: Don't taint if empty  */
3936             *d = *s;
3937         }
3938
3939         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3940          * the destination to retain that flag */
3941         if (SvUTF8(source))
3942             SvUTF8_on(dest);
3943
3944         if (!inplace) { /* Finish the rest of the string, unchanged */
3945             /* This will copy the trailing NUL  */
3946             Copy(s + 1, d + 1, slen, U8);
3947             SvCUR_set(dest, need - 1);
3948         }
3949     }
3950     SvSETMAGIC(dest);
3951     RETURN;
3952 }
3953
3954 /* There's so much setup/teardown code common between uc and lc, I wonder if
3955    it would be worth merging the two, and just having a switch outside each
3956    of the three tight loops.  There is less and less commonality though */
3957 PP(pp_uc)
3958 {
3959     dVAR;
3960     dSP;
3961     SV *source = TOPs;
3962     STRLEN len;
3963     STRLEN min;
3964     SV *dest;
3965     const U8 *s;
3966     U8 *d;
3967
3968     SvGETMAGIC(source);
3969
3970     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3971         && SvTEMP(source) && !DO_UTF8(source)
3972         && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3973
3974         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3975          * make the loop tight, so we overwrite the source with the dest before
3976          * looking at it, and we need to look at the original source
3977          * afterwards.  There would also need to be code added to handle
3978          * switching to not in-place in midstream if we run into characters
3979          * that change the length.
3980          */
3981         dest = source;
3982         s = d = (U8*)SvPV_force_nomg(source, len);
3983         min = len + 1;
3984     } else {
3985         dTARGET;
3986
3987         dest = TARG;
3988
3989         /* The old implementation would copy source into TARG at this point.
3990            This had the side effect that if source was undef, TARG was now
3991            an undefined SV with PADTMP set, and they don't warn inside
3992            sv_2pv_flags(). However, we're now getting the PV direct from
3993            source, which doesn't have PADTMP set, so it would warn. Hence the
3994            little games.  */
3995
3996         if (SvOK(source)) {
3997             s = (const U8*)SvPV_nomg_const(source, len);
3998         } else {
3999             if (ckWARN(WARN_UNINITIALIZED))
4000                 report_uninit(source);
4001             s = (const U8*)"";
4002             len = 0;
4003         }
4004         min = len + 1;
4005
4006         SvUPGRADE(dest, SVt_PV);
4007         d = (U8*)SvGROW(dest, min);
4008         (void)SvPOK_only(dest);
4009
4010         SETs(dest);
4011     }
4012
4013     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4014        to check DO_UTF8 again here.  */
4015
4016     if (DO_UTF8(source)) {
4017         const U8 *const send = s + len;
4018         U8 tmpbuf[UTF8_MAXBYTES+1];
4019
4020 /* This is ifdefd out because it needs more work and thought.  It isn't clear
4021  * that we should do it.  These are hard-coded rules from the Unicode standard,
4022  * and may change.  5.2 gives new guidance on the iota subscript, for example,
4023  * which has not been checked against this; and secondly it may be that we are
4024  * passed a subset of the context, via a \U...\E, for example, and its not
4025  * clear what the best approach is to that */
4026 #ifdef CONTEXT_DEPENDENT_CASING
4027         bool in_iota_subscript = FALSE;
4028 #endif
4029
4030         while (s < send) {
4031 #ifdef CONTEXT_DEPENDENT_CASING
4032             if (in_iota_subscript && ! is_utf8_mark(s)) {
4033                 /* A non-mark.  Time to output the iota subscript */
4034 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4035 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4036
4037                 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4038                 in_iota_subscript = FALSE;
4039             }
4040 #endif
4041
4042
4043 /* See comments at the first instance in this file of this ifdef */
4044 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4045
4046             /* If the UTF-8 character is invariant, then it is in the range
4047              * known by the standard macro; result is only one byte long */
4048             if (UTF8_IS_INVARIANT(*s)) {
4049                 *d++ = toUPPER(*s);
4050                 s++;
4051             }
4052             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4053
4054                 /* Likewise, if it fits in a byte, its case change is in our
4055                  * table */
4056                 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4057                 U8 upper = toUPPER_LATIN1_MOD(orig);
4058                 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4059                 s += 2;
4060             }
4061             else {
4062 #else
4063             {
4064 #endif
4065
4066                 /* Otherwise, need the general UTF-8 case.  Get the changed
4067                  * case value and copy it to the output buffer */
4068
4069                 const STRLEN u = UTF8SKIP(s);
4070                 STRLEN ulen;
4071
4072 #ifndef CONTEXT_DEPENDENT_CASING
4073                 toUPPER_utf8(s, tmpbuf, &ulen);
4074 #else
4075                 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4076                 if (uv == GREEK_CAPITAL_LETTER_IOTA && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI) {
4077                     in_iota_subscript = TRUE;
4078                 }
4079                 else {
4080 #endif
4081                     if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4082                         /* If the eventually required minimum size outgrows
4083                          * the available space, we need to grow. */
4084                         const UV o = d - (U8*)SvPVX_const(dest);
4085
4086                         /* If someone uppercases one million U+03B0s we
4087                          * SvGROW() one million times.  Or we could try
4088                          * guessing how much to allocate without allocating too
4089                          * much.  Such is life.  See corresponding comment in lc code
4090                          * for another option */
4091                         SvGROW(dest, min);
4092                         d = (U8*)SvPVX(dest) + o;
4093                     }
4094                     Copy(tmpbuf, d, ulen, U8);
4095                     d += ulen;
4096 #ifdef CONTEXT_DEPENDENT_CASING
4097                 }
4098 #endif
4099                 s += u;
4100             }
4101         }
4102 #ifdef CONTEXT_DEPENDENT_CASING
4103         if (in_iota_subscript) CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4104 #endif
4105         SvUTF8_on(dest);
4106         *d = '\0';
4107         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4108     } else {    /* Not UTF-8 */
4109         if (len) {
4110             const U8 *const send = s + len;
4111
4112             /* Use locale casing if in locale; regular style if not treating
4113              * latin1 as having case; otherwise the latin1 casing.  Do the
4114              * whole thing in a tight loop, for speed, */
4115             if (IN_LOCALE_RUNTIME) {
4116                 TAINT;
4117                 SvTAINTED_on(dest);
4118                 for (; s < send; d++, s++)
4119                     *d = toUPPER_LC(*s);
4120             }
4121             else if (! IN_UNI_8_BIT) {
4122                 for (; s < send; d++, s++) {
4123                     *d = toUPPER(*s);
4124                 }
4125             }
4126             else {
4127                 for (; s < send; d++, s++) {
4128                     *d = toUPPER_LATIN1_MOD(*s);
4129                     if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4130
4131                     /* The mainstream case is the tight loop above.  To avoid
4132                      * extra tests in that, all three characters that require
4133                      * special handling are mapped by the MOD to the one tested
4134                      * just above.
4135                      * Use the source to distinguish between the three cases */
4136
4137                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4138
4139                         /* uc() of this requires 2 characters, but they are
4140                          * ASCII.  If not enough room, grow the string */
4141                         if (SvLEN(dest) < ++min) {
4142                             const UV o = d - (U8*)SvPVX_const(dest);
4143                             SvGROW(dest, min);
4144                             d = (U8*)SvPVX(dest) + o;
4145                         }
4146                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4147                         continue;   /* Back to the tight loop; still in ASCII */
4148                     }
4149
4150                     /* The other two special handling characters have their
4151                      * upper cases outside the latin1 range, hence need to be
4152                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4153                      * here we are somewhere in the middle of processing a
4154                      * non-UTF-8 string, and realize that we will have to convert
4155                      * the whole thing to UTF-8.  What to do?  There are
4156                      * several possibilities.  The simplest to code is to
4157                      * convert what we have so far, set a flag, and continue on
4158                      * in the loop.  The flag would be tested each time through
4159                      * the loop, and if set, the next character would be
4160                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4161                      * to slow down the mainstream case at all for this fairly
4162                      * rare case, so I didn't want to add a test that didn't
4163                      * absolutely have to be there in the loop, besides the
4164                      * possibility that it would get too complicated for
4165                      * optimizers to deal with.  Another possibility is to just
4166                      * give up, convert the source to UTF-8, and restart the
4167                      * function that way.  Another possibility is to convert
4168                      * both what has already been processed and what is yet to
4169                      * come separately to UTF-8, then jump into the loop that
4170                      * handles UTF-8.  But the most efficient time-wise of the
4171                      * ones I could think of is what follows, and turned out to
4172                      * not require much extra code.  */
4173
4174                     /* Convert what we have so far into UTF-8, telling the
4175                      * function that we know it should be converted, and to
4176                      * allow extra space for what we haven't processed yet.
4177                      * Assume the worst case space requirements for converting
4178                      * what we haven't processed so far: that it will require
4179                      * two bytes for each remaining source character, plus the
4180                      * NUL at the end.  This may cause the string pointer to
4181                      * move, so re-find it. */
4182
4183                     len = d - (U8*)SvPVX_const(dest);
4184                     SvCUR_set(dest, len);
4185                     len = sv_utf8_upgrade_flags_grow(dest,
4186                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4187                                                 (send -s) * 2 + 1);
4188                     d = (U8*)SvPVX(dest) + len;
4189
4190                     /* And append the current character's upper case in UTF-8 */
4191                     CAT_NON_LATIN1_UC(d, *s);
4192
4193                     /* Now process the remainder of the source, converting to
4194                      * upper and UTF-8.  If a resulting byte is invariant in
4195                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4196                      * append it to the output. */
4197
4198                     s++;
4199                     for (; s < send; s++) {
4200                         U8 upper = toUPPER_LATIN1_MOD(*s);
4201                         if UTF8_IS_INVARIANT(upper) {
4202                             *d++ = upper;
4203                         }
4204                         else {
4205                             CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4206                         }
4207                     }
4208
4209                     /* Here have processed the whole source; no need to continue
4210                      * with the outer loop.  Each character has been converted
4211                      * to upper case and converted to UTF-8 */
4212
4213                     break;
4214                 } /* End of processing all latin1-style chars */
4215             } /* End of processing all chars */
4216         } /* End of source is not empty */
4217
4218         if (source != dest) {
4219             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4220             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4221         }
4222     } /* End of isn't utf8 */
4223     SvSETMAGIC(dest);
4224     RETURN;
4225 }
4226
4227 PP(pp_lc)
4228 {
4229     dVAR;
4230     dSP;
4231     SV *source = TOPs;
4232     STRLEN len;
4233     STRLEN min;
4234     SV *dest;
4235     const U8 *s;
4236     U8 *d;
4237
4238     SvGETMAGIC(source);
4239
4240     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4241         && SvTEMP(source) && !DO_UTF8(source)) {
4242
4243         /* We can convert in place, as lowercasing anything in the latin1 range
4244          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4245         dest = source;
4246         s = d = (U8*)SvPV_force_nomg(source, len);
4247         min = len + 1;
4248     } else {
4249         dTARGET;
4250
4251         dest = TARG;
4252
4253         /* The old implementation would copy source into TARG at this point.
4254            This had the side effect that if source was undef, TARG was now
4255            an undefined SV with PADTMP set, and they don't warn inside
4256            sv_2pv_flags(). However, we're now getting the PV direct from
4257            source, which doesn't have PADTMP set, so it would warn. Hence the
4258            little games.  */
4259
4260         if (SvOK(source)) {
4261             s = (const U8*)SvPV_nomg_const(source, len);
4262         } else {
4263             if (ckWARN(WARN_UNINITIALIZED))
4264                 report_uninit(source);
4265             s = (const U8*)"";
4266             len = 0;
4267         }
4268         min = len + 1;
4269
4270         SvUPGRADE(dest, SVt_PV);
4271         d = (U8*)SvGROW(dest, min);
4272         (void)SvPOK_only(dest);
4273
4274         SETs(dest);
4275     }
4276
4277     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4278        to check DO_UTF8 again here.  */
4279
4280     if (DO_UTF8(source)) {
4281         const U8 *const send = s + len;
4282         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4283
4284         while (s < send) {
4285 /* See comments at the first instance in this file of this ifdef */
4286 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4287             if (UTF8_IS_INVARIANT(*s)) {
4288
4289                 /* Invariant characters use the standard mappings compiled in.
4290                  */
4291                 *d++ = toLOWER(*s);
4292                 s++;
4293             }
4294             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4295
4296                 /* As do the ones in the Latin1 range */
4297                 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4298                 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4299                 s += 2;
4300             }
4301             else {
4302 #endif
4303                 /* Here, is utf8 not in Latin-1 range, have to go out and get
4304                  * the mappings from the tables. */
4305
4306                 const STRLEN u = UTF8SKIP(s);
4307                 STRLEN ulen;
4308
4309 /* See comments at the first instance in this file of this ifdef */
4310 #ifndef CONTEXT_DEPENDENT_CASING
4311                 toLOWER_utf8(s, tmpbuf, &ulen);
4312 #else
4313                 /* Here is context dependent casing, not compiled in currently;
4314                  * needs more thought and work */
4315
4316                 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4317
4318                 /* If the lower case is a small sigma, it may be that we need
4319                  * to change it to a final sigma.  This happens at the end of
4320                  * a word that contains more than just this character, and only
4321                  * when we started with a capital sigma. */
4322                 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4323                     s > send - len &&   /* Makes sure not the first letter */
4324                     utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4325                 ) {
4326
4327                     /* We use the algorithm in:
4328                      * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4329                      * is a CAPITAL SIGMA): If C is preceded by a sequence
4330                      * consisting of a cased letter and a case-ignorable
4331                      * sequence, and C is not followed by a sequence consisting
4332                      * of a case ignorable sequence and then a cased letter,
4333                      * then when lowercasing C, C becomes a final sigma */
4334
4335                     /* To determine if this is the end of a word, need to peek
4336                      * ahead.  Look at the next character */
4337                     const U8 *peek = s + u;
4338
4339                     /* Skip any case ignorable characters */
4340                     while (peek < send && is_utf8_case_ignorable(peek)) {
4341                         peek += UTF8SKIP(peek);
4342                     }
4343
4344                     /* If we reached the end of the string without finding any
4345                      * non-case ignorable characters, or if the next such one
4346                      * is not-cased, then we have met the conditions for it
4347                      * being a final sigma with regards to peek ahead, and so
4348                      * must do peek behind for the remaining conditions. (We
4349                      * know there is stuff behind to look at since we tested
4350                      * above that this isn't the first letter) */
4351                     if (peek >= send || ! is_utf8_cased(peek)) {
4352                         peek = utf8_hop(s, -1);
4353
4354                         /* Here are at the beginning of the first character
4355                          * before the original upper case sigma.  Keep backing
4356                          * up, skipping any case ignorable characters */
4357                         while (is_utf8_case_ignorable(peek)) {
4358                             peek = utf8_hop(peek, -1);
4359                         }
4360
4361                         /* Here peek points to the first byte of the closest
4362                          * non-case-ignorable character before the capital
4363                          * sigma.  If it is cased, then by the Unicode
4364                          * algorithm, we should use a small final sigma instead
4365                          * of what we have */
4366                         if (is_utf8_cased(peek)) {
4367                             STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4368                                         UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4369                         }
4370                     }
4371                 }
4372                 else {  /* Not a context sensitive mapping */
4373 #endif  /* End of commented out context sensitive */
4374                     if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4375
4376                         /* If the eventually required minimum size outgrows
4377                          * the available space, we need to grow. */
4378                         const UV o = d - (U8*)SvPVX_const(dest);
4379
4380                         /* If someone lowercases one million U+0130s we
4381                          * SvGROW() one million times.  Or we could try
4382                          * guessing how much to allocate without allocating too
4383                          * much.  Such is life.  Another option would be to
4384                          * grow an extra byte or two more each time we need to
4385                          * grow, which would cut down the million to 500K, with
4386                          * little waste */
4387                         SvGROW(dest, min);
4388                         d = (U8*)SvPVX(dest) + o;
4389                     }
4390 #ifdef CONTEXT_DEPENDENT_CASING
4391                 }
4392 #endif
4393                 /* Copy the newly lowercased letter to the output buffer we're
4394                  * building */
4395                 Copy(tmpbuf, d, ulen, U8);
4396                 d += ulen;
4397                 s += u;
4398 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4399             }
4400 #endif
4401         }   /* End of looping through the source string */
4402         SvUTF8_on(dest);
4403         *d = '\0';
4404         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4405     } else {    /* Not utf8 */
4406         if (len) {
4407             const U8 *const send = s + len;
4408
4409             /* Use locale casing if in locale; regular style if not treating
4410              * latin1 as having case; otherwise the latin1 casing.  Do the
4411              * whole thing in a tight loop, for speed, */
4412             if (IN_LOCALE_RUNTIME) {
4413                 TAINT;
4414                 SvTAINTED_on(dest);
4415                 for (; s < send; d++, s++)
4416                     *d = toLOWER_LC(*s);
4417             }
4418             else if (! IN_UNI_8_BIT) {
4419                 for (; s < send; d++, s++) {
4420                     *d = toLOWER(*s);
4421                 }
4422             }
4423             else {
4424                 for (; s < send; d++, s++) {
4425                     *d = toLOWER_LATIN1(*s);
4426                 }
4427             }
4428         }
4429         if (source != dest) {
4430             *d = '\0';
4431             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4432         }
4433     }
4434     SvSETMAGIC(dest);
4435     RETURN;
4436 }
4437
4438 PP(pp_quotemeta)
4439 {
4440     dVAR; dSP; dTARGET;
4441     SV * const sv = TOPs;
4442     STRLEN len;
4443     register const char *s = SvPV_const(sv,len);
4444
4445     SvUTF8_off(TARG);                           /* decontaminate */
4446     if (len) {
4447         register char *d;
4448         SvUPGRADE(TARG, SVt_PV);
4449         SvGROW(TARG, (len * 2) + 1);
4450         d = SvPVX(TARG);
4451         if (DO_UTF8(sv)) {
4452             while (len) {
4453                 if (UTF8_IS_CONTINUED(*s)) {
4454                     STRLEN ulen = UTF8SKIP(s);
4455                     if (ulen > len)
4456                         ulen = len;
4457                     len -= ulen;
4458                     while (ulen--)
4459                         *d++ = *s++;
4460                 }
4461                 else {
4462                     if (!isALNUM(*s))
4463                         *d++ = '\\';
4464                     *d++ = *s++;
4465                     len--;
4466                 }
4467             }
4468             SvUTF8_on(TARG);
4469         }
4470         else {
4471             while (len--) {
4472                 if (!isALNUM(*s))
4473                     *d++ = '\\';
4474                 *d++ = *s++;
4475             }
4476         }
4477         *d = '\0';
4478         SvCUR_set(TARG, d - SvPVX_const(TARG));
4479         (void)SvPOK_only_UTF8(TARG);
4480     }
4481     else
4482         sv_setpvn(TARG, s, len);
4483     SETTARG;
4484     RETURN;
4485 }
4486
4487 /* Arrays. */
4488
4489 PP(pp_aslice)
4490 {
4491     dVAR; dSP; dMARK; dORIGMARK;
4492     register AV *const av = MUTABLE_AV(POPs);
4493     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4494
4495     if (SvTYPE(av) == SVt_PVAV) {
4496         const I32 arybase = CopARYBASE_get(PL_curcop);
4497         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4498         bool can_preserve = FALSE;
4499
4500         if (localizing) {
4501             MAGIC *mg;
4502             HV *stash;
4503
4504             can_preserve = SvCANEXISTDELETE(av);
4505         }
4506
4507         if (lval && localizing) {
4508             register SV **svp;
4509             I32 max = -1;
4510             for (svp = MARK + 1; svp <= SP; svp++) {
4511                 const I32 elem = SvIV(*svp);
4512                 if (elem > max)
4513                     max = elem;
4514             }
4515             if (max > AvMAX(av))
4516                 av_extend(av, max);
4517         }
4518
4519         while (++MARK <= SP) {
4520             register SV **svp;
4521             I32 elem = SvIV(*MARK);
4522             bool preeminent = TRUE;
4523
4524             if (elem > 0)
4525                 elem -= arybase;
4526             if (localizing && can_preserve) {
4527                 /* If we can determine whether the element exist,
4528                  * Try to preserve the existenceness of a tied array
4529                  * element by using EXISTS and DELETE if possible.
4530                  * Fallback to FETCH and STORE otherwise. */
4531                 preeminent = av_exists(av, elem);
4532             }
4533
4534             svp = av_fetch(av, elem, lval);
4535             if (lval) {
4536                 if (!svp || *svp == &PL_sv_undef)
4537                     DIE(aTHX_ PL_no_aelem, elem);
4538                 if (localizing) {
4539                     if (preeminent)
4540                         save_aelem(av, elem, svp);
4541                     else
4542                         SAVEADELETE(av, elem);
4543                 }
4544             }
4545             *MARK = svp ? *svp : &PL_sv_undef;
4546         }
4547     }
4548     if (GIMME != G_ARRAY) {
4549         MARK = ORIGMARK;
4550         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4551         SP = MARK;
4552     }
4553     RETURN;
4554 }
4555
4556 PP(pp_aeach)
4557 {
4558     dVAR;
4559     dSP;
4560     AV *array = MUTABLE_AV(POPs);
4561     const I32 gimme = GIMME_V;
4562     IV *iterp = Perl_av_iter_p(aTHX_ array);
4563     const IV current = (*iterp)++;
4564
4565     if (current > av_len(array)) {
4566         *iterp = 0;
4567         if (gimme == G_SCALAR)
4568             RETPUSHUNDEF;
4569         else
4570             RETURN;
4571     }
4572
4573     EXTEND(SP, 2);
4574     mPUSHi(CopARYBASE_get(PL_curcop) + current);
4575     if (gimme == G_ARRAY) {
4576         SV **const element = av_fetch(array, current, 0);
4577         PUSHs(element ? *element : &PL_sv_undef);
4578     }
4579     RETURN;
4580 }
4581
4582 PP(pp_akeys)
4583 {
4584     dVAR;
4585     dSP;
4586     AV *array = MUTABLE_AV(POPs);
4587     const I32 gimme = GIMME_V;
4588
4589     *Perl_av_iter_p(aTHX_ array) = 0;
4590
4591     if (gimme == G_SCALAR) {
4592         dTARGET;
4593         PUSHi(av_len(array) + 1);
4594     }
4595     else if (gimme == G_ARRAY) {
4596         IV n = Perl_av_len(aTHX_ array);
4597         IV i = CopARYBASE_get(PL_curcop);
4598
4599         EXTEND(SP, n + 1);
4600
4601         if (PL_op->op_type == OP_AKEYS) {
4602             n += i;
4603             for (;  i <= n;  i++) {
4604                 mPUSHi(i);
4605             }
4606         }
4607         else {
4608             for (i = 0;  i <= n;  i++) {
4609                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4610                 PUSHs(elem ? *elem : &PL_sv_undef);
4611             }
4612         }
4613     }
4614     RETURN;
4615 }
4616
4617 /* Associative arrays. */
4618
4619 PP(pp_each)
4620 {
4621     dVAR;
4622     dSP;
4623     HV * hash = MUTABLE_HV(POPs);
4624     HE *entry;
4625     const I32 gimme = GIMME_V;
4626
4627     PUTBACK;
4628     /* might clobber stack_sp */
4629     entry = hv_iternext(hash);
4630     SPAGAIN;
4631
4632     EXTEND(SP, 2);
4633     if (entry) {
4634         SV* const sv = hv_iterkeysv(entry);
4635         PUSHs(sv);      /* won't clobber stack_sp */
4636         if (gimme == G_ARRAY) {
4637             SV *val;
4638             PUTBACK;
4639             /* might clobber stack_sp */
4640             val = hv_iterval(hash, entry);
4641             SPAGAIN;
4642             PUSHs(val);
4643         }
4644     }
4645     else if (gimme == G_SCALAR)
4646         RETPUSHUNDEF;
4647
4648     RETURN;
4649 }
4650
4651 STATIC OP *
4652 S_do_delete_local(pTHX)
4653 {
4654     dVAR;
4655     dSP;
4656     const I32 gimme = GIMME_V;
4657     const MAGIC *mg;
4658     HV *stash;
4659
4660     if (PL_op->op_private & OPpSLICE) {
4661         dMARK; dORIGMARK;
4662         SV * const osv = POPs;
4663         const bool tied = SvRMAGICAL(osv)
4664                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4665         const bool can_preserve = SvCANEXISTDELETE(osv)
4666                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4667         const U32 type = SvTYPE(osv);
4668         if (type == SVt_PVHV) {                 /* hash element */
4669             HV * const hv = MUTABLE_HV(osv);
4670             while (++MARK <= SP) {
4671                 SV * const keysv = *MARK;
4672                 SV *sv = NULL;
4673                 bool preeminent = TRUE;
4674                 if (can_preserve)
4675                     preeminent = hv_exists_ent(hv, keysv, 0);
4676                 if (tied) {
4677                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4678                     if (he)
4679                         sv = HeVAL(he);
4680                     else
4681                         preeminent = FALSE;
4682                 }
4683                 else {
4684                     sv = hv_delete_ent(hv, keysv, 0, 0);
4685                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4686                 }
4687                 if (preeminent) {
4688                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4689                     if (tied) {
4690                         *MARK = sv_mortalcopy(sv);
4691                         mg_clear(sv);
4692                     } else
4693                         *MARK = sv;
4694                 }
4695                 else {
4696                     SAVEHDELETE(hv, keysv);
4697                     *MARK = &PL_sv_undef;
4698                 }
4699             }
4700         }
4701         else if (type == SVt_PVAV) {                  /* array element */
4702             if (PL_op->op_flags & OPf_SPECIAL) {
4703                 AV * const av = MUTABLE_AV(osv);
4704                 while (++MARK <= SP) {
4705                     I32 idx = SvIV(*MARK);
4706                     SV *sv = NULL;
4707                     bool preeminent = TRUE;
4708                     if (can_preserve)
4709                         preeminent = av_exists(av, idx);
4710                     if (tied) {
4711                         SV **svp = av_fetch(av, idx, 1);
4712                         if (svp)
4713                             sv = *svp;
4714                         else
4715                             preeminent = FALSE;
4716                     }
4717                     else {
4718                         sv = av_delete(av, idx, 0);
4719                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4720                     }
4721                     if (preeminent) {
4722                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4723                         if (tied) {
4724                             *MARK = sv_mortalcopy(sv);
4725                             mg_clear(sv);
4726                         } else
4727                             *MARK = sv;
4728                     }
4729                     else {
4730                         SAVEADELETE(av, idx);
4731                         *MARK = &PL_sv_undef;
4732                     }
4733                 }
4734             }
4735         }
4736         else
4737             DIE(aTHX_ "Not a HASH reference");
4738         if (gimme == G_VOID)
4739             SP = ORIGMARK;
4740         else if (gimme == G_SCALAR) {
4741             MARK = ORIGMARK;
4742             if (SP > MARK)
4743                 *++MARK = *SP;
4744             else
4745                 *++MARK = &PL_sv_undef;
4746             SP = MARK;
4747         }
4748     }
4749     else {
4750         SV * const keysv = POPs;
4751         SV * const osv   = POPs;
4752         const bool tied = SvRMAGICAL(osv)
4753                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4754         const bool can_preserve = SvCANEXISTDELETE(osv)
4755                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4756         const U32 type = SvTYPE(osv);
4757         SV *sv = NULL;
4758         if (type == SVt_PVHV) {
4759             HV * const hv = MUTABLE_HV(osv);
4760             bool preeminent = TRUE;
4761             if (can_preserve)
4762                 preeminent = hv_exists_ent(hv, keysv, 0);
4763             if (tied) {
4764                 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4765                 if (he)
4766                     sv = HeVAL(he);
4767                 else
4768                     preeminent = FALSE;
4769             }
4770             else {
4771                 sv = hv_delete_ent(hv, keysv, 0, 0);
4772                 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4773             }
4774             if (preeminent) {
4775                 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4776                 if (tied) {
4777                     SV *nsv = sv_mortalcopy(sv);
4778                     mg_clear(sv);
4779                     sv = nsv;
4780                 }
4781             }
4782             else
4783                 SAVEHDELETE(hv, keysv);
4784         }
4785         else if (type == SVt_PVAV) {
4786             if (PL_op->op_flags & OPf_SPECIAL) {
4787                 AV * const av = MUTABLE_AV(osv);
4788                 I32 idx = SvIV(keysv);
4789                 bool preeminent = TRUE;
4790                 if (can_preserve)
4791                     preeminent = av_exists(av, idx);
4792                 if (tied) {
4793                     SV **svp = av_fetch(av, idx, 1);
4794                     if (svp)
4795                         sv = *svp;
4796                     else
4797                         preeminent = FALSE;
4798                 }
4799                 else {
4800                     sv = av_delete(av, idx, 0);
4801                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4802                 }
4803                 if (preeminent) {
4804                     save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4805                     if (tied) {
4806                         SV *nsv = sv_mortalcopy(sv);
4807                         mg_clear(sv);
4808                         sv = nsv;
4809                     }
4810                 }
4811                 else
4812                     SAVEADELETE(av, idx);
4813             }
4814             else
4815                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4816         }
4817         else
4818             DIE(aTHX_ "Not a HASH reference");
4819         if (!sv)
4820             sv = &PL_sv_undef;
4821         if (gimme != G_VOID)
4822             PUSHs(sv);
4823     }
4824
4825     RETURN;
4826 }
4827
4828 PP(pp_delete)
4829 {
4830     dVAR;
4831     dSP;
4832     I32 gimme;
4833     I32 discard;
4834
4835     if (PL_op->op_private & OPpLVAL_INTRO)
4836         return do_delete_local();
4837
4838     gimme = GIMME_V;
4839     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4840
4841     if (PL_op->op_private & OPpSLICE) {
4842         dMARK; dORIGMARK;
4843         HV * const hv = MUTABLE_HV(POPs);
4844         const U32 hvtype = SvTYPE(hv);
4845         if (hvtype == SVt_PVHV) {                       /* hash element */
4846             while (++MARK <= SP) {
4847                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4848                 *MARK = sv ? sv : &PL_sv_undef;
4849             }
4850         }
4851         else if (hvtype == SVt_PVAV) {                  /* array element */
4852             if (PL_op->op_flags & OPf_SPECIAL) {
4853                 while (++MARK <= SP) {
4854                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4855                     *MARK = sv ? sv : &PL_sv_undef;
4856                 }
4857             }
4858         }
4859         else
4860             DIE(aTHX_ "Not a HASH reference");
4861         if (discard)
4862             SP = ORIGMARK;
4863         else if (gimme == G_SCALAR) {
4864             MARK = ORIGMARK;
4865             if (SP > MARK)
4866                 *++MARK = *SP;
4867             else
4868                 *++MARK = &PL_sv_undef;
4869             SP = MARK;
4870         }
4871     }
4872     else {
4873         SV *keysv = POPs;
4874         HV * const hv = MUTABLE_HV(POPs);
4875         SV *sv = NULL;
4876         if (SvTYPE(hv) == SVt_PVHV)
4877             sv = hv_delete_ent(hv, keysv, discard, 0);
4878         else if (SvTYPE(hv) == SVt_PVAV) {
4879             if (PL_op->op_flags & OPf_SPECIAL)
4880                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4881             else
4882                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4883         }
4884         else
4885             DIE(aTHX_ "Not a HASH reference");
4886         if (!sv)
4887             sv = &PL_sv_undef;
4888         if (!discard)
4889             PUSHs(sv);
4890     }
4891     RETURN;
4892 }
4893
4894 PP(pp_exists)
4895 {
4896     dVAR;
4897     dSP;
4898     SV *tmpsv;
4899     HV *hv;
4900
4901     if (PL_op->op_private & OPpEXISTS_SUB) {
4902         GV *gv;
4903         SV * const sv = POPs;
4904         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4905         if (cv)
4906             RETPUSHYES;
4907         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4908             RETPUSHYES;
4909         RETPUSHNO;
4910     }
4911     tmpsv = POPs;
4912     hv = MUTABLE_HV(POPs);
4913     if (SvTYPE(hv) == SVt_PVHV) {
4914         if (hv_exists_ent(hv, tmpsv, 0))
4915             RETPUSHYES;
4916     }
4917     else if (SvTYPE(hv) == SVt_PVAV) {
4918         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4919             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4920                 RETPUSHYES;
4921         }
4922     }
4923     else {
4924         DIE(aTHX_ "Not a HASH reference");
4925     }
4926     RETPUSHNO;
4927 }
4928
4929 PP(pp_hslice)
4930 {
4931     dVAR; dSP; dMARK; dORIGMARK;
4932     register HV * const hv = MUTABLE_HV(POPs);
4933     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4934     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4935     bool can_preserve = FALSE;
4936
4937     if (localizing) {
4938         MAGIC *mg;
4939         HV *stash;
4940
4941         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4942             can_preserve = TRUE;
4943     }
4944
4945     while (++MARK <= SP) {
4946         SV * const keysv = *MARK;
4947         SV **svp;
4948         HE *he;
4949         bool preeminent = TRUE;
4950
4951         if (localizing && can_preserve) {
4952             /* If we can determine whether the element exist,
4953              * try to preserve the existenceness of a tied hash
4954              * element by using EXISTS and DELETE if possible.
4955              * Fallback to FETCH and STORE otherwise. */
4956             preeminent = hv_exists_ent(hv, keysv, 0);
4957         }
4958
4959         he = hv_fetch_ent(hv, keysv, lval, 0);
4960         svp = he ? &HeVAL(he) : NULL;
4961
4962         if (lval) {
4963             if (!svp || *svp == &PL_sv_undef) {
4964                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4965             }
4966             if (localizing) {
4967                 if (HvNAME_get(hv) && isGV(*svp))
4968                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4969                 else if (preeminent)
4970                     save_helem_flags(hv, keysv, svp,
4971                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4972                 else
4973                     SAVEHDELETE(hv, keysv);
4974             }
4975         }
4976         *MARK = svp ? *svp : &PL_sv_undef;
4977     }
4978     if (GIMME != G_ARRAY) {
4979         MARK = ORIGMARK;
4980         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4981         SP = MARK;
4982     }
4983     RETURN;
4984 }
4985
4986 /* List operators. */
4987
4988 PP(pp_list)
4989 {
4990     dVAR; dSP; dMARK;
4991     if (GIMME != G_ARRAY) {
4992         if (++MARK <= SP)
4993             *MARK = *SP;                /* unwanted list, return last item */
4994         else
4995             *MARK = &PL_sv_undef;
4996         SP = MARK;
4997     }
4998     RETURN;
4999 }
5000
5001 PP(pp_lslice)
5002 {
5003     dVAR;
5004     dSP;
5005     SV ** const lastrelem = PL_stack_sp;
5006     SV ** const lastlelem = PL_stack_base + POPMARK;
5007     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5008     register SV ** const firstrelem = lastlelem + 1;
5009     const I32 arybase = CopARYBASE_get(PL_curcop);
5010     I32 is_something_there = FALSE;
5011
5012     register const I32 max = lastrelem - lastlelem;
5013     register SV **lelem;
5014
5015     if (GIMME != G_ARRAY) {
5016         I32 ix = SvIV(*lastlelem);
5017         if (ix < 0)
5018             ix += max;
5019         else
5020             ix -= arybase;
5021         if (ix < 0 || ix >= max)
5022             *firstlelem = &PL_sv_undef;
5023         else
5024             *firstlelem = firstrelem[ix];
5025         SP = firstlelem;
5026         RETURN;
5027     }
5028
5029     if (max == 0) {
5030         SP = firstlelem - 1;
5031         RETURN;
5032     }
5033
5034     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5035         I32 ix = SvIV(*lelem);
5036         if (ix < 0)
5037             ix += max;
5038         else
5039             ix -= arybase;
5040         if (ix < 0 || ix >= max)
5041             *lelem = &PL_sv_undef;
5042         else {
5043             is_something_there = TRUE;
5044             if (!(*lelem = firstrelem[ix]))
5045                 *lelem = &PL_sv_undef;
5046         }
5047     }
5048     if (is_something_there)
5049         SP = lastlelem;
5050     else
5051         SP = firstlelem - 1;
5052     RETURN;
5053 }
5054
5055 PP(pp_anonlist)
5056 {
5057     dVAR; dSP; dMARK; dORIGMARK;
5058     const I32 items = SP - MARK;
5059     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5060     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
5061     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5062             ? newRV_noinc(av) : av);
5063     RETURN;
5064 }
5065
5066 PP(pp_anonhash)
5067 {
5068     dVAR; dSP; dMARK; dORIGMARK;
5069     HV* const hv = newHV();
5070
5071     while (MARK < SP) {
5072         SV * const key = *++MARK;
5073         SV * const val = newSV(0);
5074         if (MARK < SP)
5075             sv_setsv(val, *++MARK);
5076         else
5077             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5078         (void)hv_store_ent(hv,key,val,0);
5079     }
5080     SP = ORIGMARK;
5081     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5082             ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5083     RETURN;
5084 }
5085
5086 PP(pp_splice)
5087 {
5088     dVAR; dSP; dMARK; dORIGMARK;
5089     register AV *ary = MUTABLE_AV(*++MARK);
5090     register SV **src;
5091     register SV **dst;
5092     register I32 i;
5093     register I32 offset;
5094     register I32 length;
5095     I32 newlen;
5096     I32 after;
5097     I32 diff;
5098     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5099
5100     if (mg) {
5101         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5102         PUSHMARK(MARK);
5103         PUTBACK;
5104         ENTER_with_name("call_SPLICE");
5105         call_method("SPLICE",GIMME_V);
5106         LEAVE_with_name("call_SPLICE");
5107         SPAGAIN;
5108         RETURN;
5109     }
5110
5111     SP++;
5112
5113     if (++MARK < SP) {
5114         offset = i = SvIV(*MARK);
5115         if (offset < 0)
5116             offset += AvFILLp(ary) + 1;
5117         else
5118             offset -= CopARYBASE_get(PL_curcop);
5119         if (offset < 0)
5120             DIE(aTHX_ PL_no_aelem, i);
5121         if (++MARK < SP) {
5122             length = SvIVx(*MARK++);
5123             if (length < 0) {
5124                 length += AvFILLp(ary) - offset + 1;
5125                 if (length < 0)
5126                     length = 0;
5127             }
5128         }
5129         else
5130             length = AvMAX(ary) + 1;            /* close enough to infinity */
5131     }
5132     else {
5133         offset = 0;
5134         length = AvMAX(ary) + 1;
5135     }
5136     if (offset > AvFILLp(ary) + 1) {
5137         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5138         offset = AvFILLp(ary) + 1;
5139     }
5140     after = AvFILLp(ary) + 1 - (offset + length);
5141     if (after < 0) {                            /* not that much array */
5142         length += after;                        /* offset+length now in array */
5143         after = 0;
5144         if (!AvALLOC(ary))
5145             av_extend(ary, 0);
5146     }
5147
5148     /* At this point, MARK .. SP-1 is our new LIST */
5149
5150     newlen = SP - MARK;
5151     diff = newlen - length;
5152     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5153         av_reify(ary);
5154
5155     /* make new elements SVs now: avoid problems if they're from the array */
5156     for (dst = MARK, i = newlen; i; i--) {
5157         SV * const h = *dst;
5158         *dst++ = newSVsv(h);
5159     }
5160
5161     if (diff < 0) {                             /* shrinking the area */
5162         SV **tmparyval = NULL;
5163         if (newlen) {
5164             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5165             Copy(MARK, tmparyval, newlen, SV*);
5166         }
5167
5168         MARK = ORIGMARK + 1;
5169         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5170             MEXTEND(MARK, length);
5171             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5172             if (AvREAL(ary)) {
5173                 EXTEND_MORTAL(length);
5174                 for (i = length, dst = MARK; i; i--) {
5175                     sv_2mortal(*dst);   /* free them eventualy */
5176                     dst++;
5177                 }
5178             }
5179             MARK += length - 1;
5180         }
5181         else {
5182             *MARK = AvARRAY(ary)[offset+length-1];
5183             if (AvREAL(ary)) {
5184                 sv_2mortal(*MARK);
5185                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5186                     SvREFCNT_dec(*dst++);       /* free them now */
5187             }
5188         }
5189         AvFILLp(ary) += diff;
5190
5191         /* pull up or down? */
5192
5193         if (offset < after) {                   /* easier to pull up */
5194             if (offset) {                       /* esp. if nothing to pull */
5195                 src = &AvARRAY(ary)[offset-1];
5196                 dst = src - diff;               /* diff is negative */
5197                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5198                     *dst-- = *src--;
5199             }
5200             dst = AvARRAY(ary);
5201             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5202             AvMAX(ary) += diff;
5203         }
5204         else {
5205             if (after) {                        /* anything to pull down? */
5206                 src = AvARRAY(ary) + offset + length;
5207                 dst = src + diff;               /* diff is negative */
5208                 Move(src, dst, after, SV*);
5209             }
5210             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5211                                                 /* avoid later double free */
5212         }
5213         i = -diff;
5214         while (i)
5215             dst[--i] = &PL_sv_undef;
5216
5217         if (newlen) {
5218             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5219             Safefree(tmparyval);
5220         }
5221     }
5222     else {                                      /* no, expanding (or same) */
5223         SV** tmparyval = NULL;
5224         if (length) {
5225             Newx(tmparyval, length, SV*);       /* so remember deletion */
5226             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5227         }
5228
5229         if (diff > 0) {                         /* expanding */
5230             /* push up or down? */
5231             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5232                 if (offset) {
5233                     src = AvARRAY(ary);
5234                     dst = src - diff;
5235                     Move(src, dst, offset, SV*);
5236                 }
5237                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5238                 AvMAX(ary) += diff;
5239                 AvFILLp(ary) += diff;
5240             }
5241             else {
5242                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5243                     av_extend(ary, AvFILLp(ary) + diff);
5244                 AvFILLp(ary) += diff;
5245
5246                 if (after) {
5247                     dst = AvARRAY(ary) + AvFILLp(ary);
5248                     src = dst - diff;
5249                     for (i = after; i; i--) {
5250                         *dst-- = *src--;
5251                     }
5252                 }
5253             }
5254         }
5255
5256         if (newlen) {
5257             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5258         }
5259
5260         MARK = ORIGMARK + 1;
5261         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5262             if (length) {
5263                 Copy(tmparyval, MARK, length, SV*);
5264                 if (AvREAL(ary)) {
5265                     EXTEND_MORTAL(length);
5266                     for (i = length, dst = MARK; i; i--) {
5267                         sv_2mortal(*dst);       /* free them eventualy */
5268                         dst++;
5269                     }
5270                 }
5271             }
5272             MARK += length - 1;
5273         }
5274         else if (length--) {
5275             *MARK = tmparyval[length];
5276             if (AvREAL(ary)) {
5277                 sv_2mortal(*MARK);
5278                 while (length-- > 0)
5279                     SvREFCNT_dec(tmparyval[length]);
5280             }
5281         }
5282         else
5283             *MARK = &PL_sv_undef;
5284         Safefree(tmparyval);
5285     }
5286     SP = MARK;
5287     RETURN;
5288 }
5289
5290 PP(pp_push)
5291 {
5292     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5293     register AV * const ary = MUTABLE_AV(*++MARK);
5294     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5295
5296     if (mg) {
5297         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5298         PUSHMARK(MARK);
5299         PUTBACK;
5300         ENTER_with_name("call_PUSH");
5301         call_method("PUSH",G_SCALAR|G_DISCARD);
5302         LEAVE_with_name("call_PUSH");
5303         SPAGAIN;
5304     }
5305     else {
5306         PL_delaymagic = DM_DELAY;
5307         for (++MARK; MARK <= SP; MARK++) {
5308             SV * const sv = newSV(0);
5309             if (*MARK)
5310                 sv_setsv(sv, *MARK);
5311             av_store(ary, AvFILLp(ary)+1, sv);
5312         }
5313         if (PL_delaymagic & DM_ARRAY)
5314             mg_set(MUTABLE_SV(ary));
5315
5316         PL_delaymagic = 0;
5317     }
5318     SP = ORIGMARK;
5319     if (OP_GIMME(PL_op, 0) != G_VOID) {
5320         PUSHi( AvFILL(ary) + 1 );
5321     }
5322     RETURN;
5323 }
5324
5325 PP(pp_shift)
5326 {
5327     dVAR;
5328     dSP;
5329     AV * const av = PL_op->op_flags & OPf_SPECIAL
5330         ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5331     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5332     EXTEND(SP, 1);
5333     assert (sv);
5334     if (AvREAL(av))
5335         (void)sv_2mortal(sv);
5336     PUSHs(sv);
5337     RETURN;
5338 }
5339
5340 PP(pp_unshift)
5341 {
5342     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5343     register AV *ary = MUTABLE_AV(*++MARK);
5344     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5345
5346     if (mg) {
5347         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5348         PUSHMARK(MARK);
5349         PUTBACK;
5350         ENTER_with_name("call_UNSHIFT");
5351         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5352         LEAVE_with_name("call_UNSHIFT");
5353         SPAGAIN;
5354     }
5355     else {
5356         register I32 i = 0;
5357         av_unshift(ary, SP - MARK);
5358         while (MARK < SP) {
5359             SV * const sv = newSVsv(*++MARK);
5360             (void)av_store(ary, i++, sv);
5361         }
5362     }
5363     SP = ORIGMARK;
5364     if (OP_GIMME(PL_op, 0) != G_VOID) {
5365         PUSHi( AvFILL(ary) + 1 );
5366     }
5367     RETURN;
5368 }
5369
5370 PP(pp_reverse)
5371 {
5372     dVAR; dSP; dMARK;
5373
5374     if (GIMME == G_ARRAY) {
5375         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5376             AV *av;
5377
5378             /* See pp_sort() */
5379             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5380             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5381             av = MUTABLE_AV((*SP));
5382             /* In-place reversing only happens in void context for the array
5383              * assignment. We don't need to push anything on the stack. */
5384             SP = MARK;
5385
5386             if (SvMAGICAL(av)) {
5387                 I32 i, j;
5388                 register SV *tmp = sv_newmortal();
5389                 /* For SvCANEXISTDELETE */
5390                 HV *stash;
5391                 const MAGIC *mg;
5392                 bool can_preserve = SvCANEXISTDELETE(av);
5393
5394                 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5395                     register SV *begin, *end;
5396
5397                     if (can_preserve) {
5398                         if (!av_exists(av, i)) {
5399                             if (av_exists(av, j)) {
5400                                 register SV *sv = av_delete(av, j, 0);
5401                                 begin = *av_fetch(av, i, TRUE);
5402                                 sv_setsv_mg(begin, sv);
5403                             }
5404                             continue;
5405                         }
5406                         else if (!av_exists(av, j)) {
5407                             register SV *sv = av_delete(av, i, 0);
5408                             end = *av_fetch(av, j, TRUE);
5409                             sv_setsv_mg(end, sv);
5410                             continue;
5411                         }
5412                     }
5413
5414                     begin = *av_fetch(av, i, TRUE);
5415                     end   = *av_fetch(av, j, TRUE);
5416                     sv_setsv(tmp,      begin);
5417                     sv_setsv_mg(begin, end);
5418                     sv_setsv_mg(end,   tmp);
5419                 }
5420             }
5421             else {
5422                 SV **begin = AvARRAY(av);
5423
5424                 if (begin) {
5425                     SV **end   = begin + AvFILLp(av);
5426
5427                     while (begin < end) {
5428                         register SV * const tmp = *begin;
5429                         *begin++ = *end;
5430                         *end--   = tmp;
5431                     }
5432                 }
5433             }
5434         }
5435         else {
5436             SV **oldsp = SP;
5437             MARK++;
5438             while (MARK < SP) {
5439                 register SV * const tmp = *MARK;
5440                 *MARK++ = *SP;
5441                 *SP--   = tmp;
5442             }
5443             /* safe as long as stack cannot get extended in the above */
5444             SP = oldsp;
5445         }
5446     }
5447     else {
5448         register char *up;
5449         register char *down;
5450         register I32 tmp;
5451         dTARGET;
5452         STRLEN len;
5453         PADOFFSET padoff_du;
5454
5455         SvUTF8_off(TARG);                               /* decontaminate */
5456         if (SP - MARK > 1)
5457             do_join(TARG, &PL_sv_no, MARK, SP);
5458         else {
5459             sv_setsv(TARG, (SP > MARK)
5460                     ? *SP
5461                     : (padoff_du = find_rundefsvoffset(),
5462                         (padoff_du == NOT_IN_PAD
5463                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
5464                         ? DEFSV : PAD_SVl(padoff_du)));
5465
5466             if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5467                 report_uninit(TARG);
5468         }
5469
5470         up = SvPV_force(TARG, len);
5471         if (len > 1) {
5472             if (DO_UTF8(TARG)) {        /* first reverse each character */
5473                 U8* s = (U8*)SvPVX(TARG);
5474                 const U8* send = (U8*)(s + len);
5475                 while (s < send) {
5476                     if (UTF8_IS_INVARIANT(*s)) {
5477                         s++;
5478                         continue;
5479                     }
5480                     else {
5481                         if (!utf8_to_uvchr(s, 0))
5482                             break;
5483                         up = (char*)s;
5484                         s += UTF8SKIP(s);
5485                         down = (char*)(s - 1);
5486                         /* reverse this character */
5487                         while (down > up) {
5488                             tmp = *up;
5489                             *up++ = *down;
5490                             *down-- = (char)tmp;
5491                         }
5492                     }
5493                 }
5494                 up = SvPVX(TARG);
5495             }
5496             down = SvPVX(TARG) + len - 1;
5497             while (down > up) {
5498                 tmp = *up;
5499                 *up++ = *down;
5500                 *down-- = (char)tmp;
5501             }
5502             (void)SvPOK_only_UTF8(TARG);
5503         }
5504         SP = MARK + 1;
5505         SETTARG;
5506     }
5507     RETURN;
5508 }
5509
5510 PP(pp_split)
5511 {
5512     dVAR; dSP; dTARG;
5513     AV *ary;
5514     register IV limit = POPi;                   /* note, negative is forever */
5515     SV * const sv = POPs;
5516     STRLEN len;
5517     register const char *s = SvPV_const(sv, len);
5518     const bool do_utf8 = DO_UTF8(sv);
5519     const char *strend = s + len;
5520     register PMOP *pm;
5521     register REGEXP *rx;
5522     register SV *dstr;
5523     register const char *m;
5524     I32 iters = 0;
5525     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5526     I32 maxiters = slen + 10;
5527     I32 trailing_empty = 0;
5528     const char *orig;
5529     const I32 origlimit = limit;
5530     I32 realarray = 0;
5531     I32 base;
5532     const I32 gimme = GIMME_V;
5533     bool gimme_scalar;
5534     const I32 oldsave = PL_savestack_ix;
5535     U32 make_mortal = SVs_TEMP;
5536     bool multiline = 0;
5537     MAGIC *mg = NULL;
5538
5539 #ifdef DEBUGGING
5540     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5541 #else
5542     pm = (PMOP*)POPs;
5543 #endif
5544     if (!pm || !s)
5545         DIE(aTHX_ "panic: pp_split");
5546     rx = PM_GETRE(pm);
5547
5548     TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5549              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5550
5551     RX_MATCH_UTF8_set(rx, do_utf8);
5552
5553 #ifdef USE_ITHREADS
5554     if (pm->op_pmreplrootu.op_pmtargetoff) {
5555         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5556     }
5557 #else
5558     if (pm->op_pmreplrootu.op_pmtargetgv) {
5559         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5560     }
5561 #endif
5562     else
5563         ary = NULL;
5564     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5565         realarray = 1;
5566         PUTBACK;
5567         av_extend(ary,0);
5568         av_clear(ary);
5569         SPAGAIN;
5570         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5571             PUSHMARK(SP);
5572             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5573         }
5574         else {
5575             if (!AvREAL(ary)) {
5576                 I32 i;
5577                 AvREAL_on(ary);
5578                 AvREIFY_off(ary);
5579                 for (i = AvFILLp(ary); i >= 0; i--)
5580                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5581             }
5582             /* temporarily switch stacks */
5583             SAVESWITCHSTACK(PL_curstack, ary);
5584             make_mortal = 0;
5585         }
5586     }
5587     base = SP - PL_stack_base;
5588     orig = s;
5589     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5590         if (do_utf8) {
5591             while (*s == ' ' || is_utf8_space((U8*)s))
5592                 s += UTF8SKIP(s);
5593         }
5594         else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5595             while (isSPACE_LC(*s))
5596                 s++;
5597         }
5598         else {
5599             while (isSPACE(*s))
5600                 s++;
5601         }
5602     }
5603     if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5604         multiline = 1;
5605     }
5606
5607     gimme_scalar = gimme == G_SCALAR && !ary;
5608
5609     if (!limit)
5610         limit = maxiters + 2;
5611     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5612         while (--limit) {
5613             m = s;
5614             /* this one uses 'm' and is a negative test */
5615             if (do_utf8) {
5616                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5617                     const int t = UTF8SKIP(m);
5618                     /* is_utf8_space returns FALSE for malform utf8 */
5619                     if (strend - m < t)
5620                         m = strend;
5621                     else
5622                         m += t;
5623                 }
5624             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5625                 while (m < strend && !isSPACE_LC(*m))
5626                     ++m;
5627             } else {
5628                 while (m < strend && !isSPACE(*m))
5629                     ++m;
5630             }
5631             if (m >= strend)
5632                 break;
5633
5634             if (gimme_scalar) {
5635                 iters++;
5636                 if (m-s == 0)
5637                     trailing_empty++;
5638                 else
5639                     trailing_empty = 0;
5640             } else {
5641                 dstr = newSVpvn_flags(s, m-s,
5642                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5643                 XPUSHs(dstr);
5644             }
5645
5646             /* skip the whitespace found last */
5647             if (do_utf8)
5648                 s = m + UTF8SKIP(m);
5649             else
5650                 s = m + 1;
5651
5652             /* this one uses 's' and is a positive test */
5653             if (do_utf8) {
5654                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5655                     s +=  UTF8SKIP(s);
5656             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5657                 while (s < strend && isSPACE_LC(*s))
5658                     ++s;
5659             } else {
5660                 while (s < strend && isSPACE(*s))
5661                     ++s;
5662             }
5663         }
5664     }
5665     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5666         while (--limit) {
5667             for (m = s; m < strend && *m != '\n'; m++)
5668                 ;
5669             m++;
5670             if (m >= strend)
5671                 break;
5672
5673             if (gimme_scalar) {
5674                 iters++;
5675                 if (m-s == 0)
5676                     trailing_empty++;
5677                 else
5678                     trailing_empty = 0;
5679             } else {
5680                 dstr = newSVpvn_flags(s, m-s,
5681                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5682                 XPUSHs(dstr);
5683             }
5684             s = m;
5685         }
5686     }
5687     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5688         /*
5689           Pre-extend the stack, either the number of bytes or
5690           characters in the string or a limited amount, triggered by:
5691
5692           my ($x, $y) = split //, $str;
5693             or
5694           split //, $str, $i;
5695         */
5696         if (!gimme_scalar) {
5697             const U32 items = limit - 1;
5698             if (items < slen)
5699                 EXTEND(SP, items);
5700             else
5701                 EXTEND(SP, slen);
5702         }
5703
5704         if (do_utf8) {
5705             while (--limit) {
5706                 /* keep track of how many bytes we skip over */
5707                 m = s;
5708                 s += UTF8SKIP(s);
5709                 if (gimme_scalar) {
5710                     iters++;
5711                     if (s-m == 0)
5712                         trailing_empty++;
5713                     else
5714                         trailing_empty = 0;
5715                 } else {
5716                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5717
5718                     PUSHs(dstr);
5719                 }
5720
5721                 if (s >= strend)
5722                     break;
5723             }
5724         } else {
5725             while (--limit) {
5726                 if (gimme_scalar) {
5727                     iters++;
5728                 } else {
5729                     dstr = newSVpvn(s, 1);
5730
5731
5732                     if (make_mortal)
5733                         sv_2mortal(dstr);
5734
5735                     PUSHs(dstr);
5736                 }
5737
5738                 s++;
5739
5740                 if (s >= strend)
5741                     break;
5742             }
5743         }
5744     }
5745     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5746              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5747              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5748              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5749         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5750         SV * const csv = CALLREG_INTUIT_STRING(rx);
5751
5752         len = RX_MINLENRET(rx);
5753         if (len == 1 && !RX_UTF8(rx) && !tail) {
5754             const char c = *SvPV_nolen_const(csv);
5755             while (--limit) {
5756                 for (m = s; m < strend && *m != c; m++)
5757                     ;
5758                 if (m >= strend)
5759                     break;
5760                 if (gimme_scalar) {
5761                     iters++;
5762                     if (m-s == 0)
5763                         trailing_empty++;
5764                     else
5765                         trailing_empty = 0;
5766                 } else {
5767                     dstr = newSVpvn_flags(s, m-s,
5768                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5769                     XPUSHs(dstr);
5770                 }
5771                 /* The rx->minlen is in characters but we want to step
5772                  * s ahead by bytes. */
5773                 if (do_utf8)
5774                     s = (char*)utf8_hop((U8*)m, len);
5775                 else
5776                     s = m + len; /* Fake \n at the end */
5777             }
5778         }
5779         else {
5780             while (s < strend && --limit &&
5781               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5782                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5783             {
5784                 if (gimme_scalar) {
5785                     iters++;
5786                     if (m-s == 0)
5787                         trailing_empty++;
5788                     else
5789                         trailing_empty = 0;
5790                 } else {
5791                     dstr = newSVpvn_flags(s, m-s,
5792                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5793                     XPUSHs(dstr);
5794                 }
5795                 /* The rx->minlen is in characters but we want to step
5796                  * s ahead by bytes. */
5797                 if (do_utf8)
5798                     s = (char*)utf8_hop((U8*)m, len);
5799                 else
5800                     s = m + len; /* Fake \n at the end */
5801             }
5802         }
5803     }
5804     else {
5805         maxiters += slen * RX_NPARENS(rx);
5806         while (s < strend && --limit)
5807         {
5808             I32 rex_return;
5809             PUTBACK;
5810             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5811                             sv, NULL, 0);
5812             SPAGAIN;
5813             if (rex_return == 0)
5814                 break;
5815             TAINT_IF(RX_MATCH_TAINTED(rx));
5816             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5817                 m = s;
5818                 s = orig;
5819                 orig = RX_SUBBEG(rx);
5820                 s = orig + (m - s);
5821                 strend = s + (strend - m);
5822             }
5823             m = RX_OFFS(rx)[0].start + orig;
5824
5825             if (gimme_scalar) {
5826                 iters++;
5827                 if (m-s == 0)
5828                     trailing_empty++;
5829                 else
5830                     trailing_empty = 0;
5831             } else {
5832                 dstr = newSVpvn_flags(s, m-s,
5833                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5834                 XPUSHs(dstr);
5835             }
5836             if (RX_NPARENS(rx)) {
5837                 I32 i;
5838                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5839                     s = RX_OFFS(rx)[i].start + orig;
5840                     m = RX_OFFS(rx)[i].end + orig;
5841
5842                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5843                        parens that didn't match -- they should be set to
5844                        undef, not the empty string */
5845                     if (gimme_scalar) {
5846                         iters++;
5847                         if (m-s == 0)
5848                             trailing_empty++;
5849                         else
5850                             trailing_empty = 0;
5851                     } else {
5852                         if (m >= orig && s >= orig) {
5853                             dstr = newSVpvn_flags(s, m-s,
5854                                                  (do_utf8 ? SVf_UTF8 : 0)
5855                                                   | make_mortal);
5856                         }
5857                         else
5858                             dstr = &PL_sv_undef;  /* undef, not "" */
5859                         XPUSHs(dstr);
5860                     }
5861
5862                 }
5863             }
5864             s = RX_OFFS(rx)[0].end + orig;
5865         }
5866     }
5867
5868     if (!gimme_scalar) {
5869         iters = (SP - PL_stack_base) - base;
5870     }
5871     if (iters > maxiters)
5872         DIE(aTHX_ "Split loop");
5873
5874     /* keep field after final delim? */
5875     if (s < strend || (iters && origlimit)) {
5876         if (!gimme_scalar) {
5877             const STRLEN l = strend - s;
5878             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5879             XPUSHs(dstr);
5880         }
5881         iters++;
5882     }
5883     else if (!origlimit) {
5884         if (gimme_scalar) {
5885             iters -= trailing_empty;
5886         } else {
5887             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5888                 if (TOPs && !make_mortal)
5889                     sv_2mortal(TOPs);
5890                 *SP-- = &PL_sv_undef;
5891                 iters--;
5892             }
5893         }
5894     }
5895
5896     PUTBACK;
5897     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5898     SPAGAIN;
5899     if (realarray) {
5900         if (!mg) {
5901             if (SvSMAGICAL(ary)) {
5902                 PUTBACK;
5903                 mg_set(MUTABLE_SV(ary));
5904                 SPAGAIN;
5905             }
5906             if (gimme == G_ARRAY) {
5907                 EXTEND(SP, iters);
5908                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5909                 SP += iters;
5910                 RETURN;
5911             }
5912         }
5913         else {
5914             PUTBACK;
5915             ENTER_with_name("call_PUSH");
5916             call_method("PUSH",G_SCALAR|G_DISCARD);
5917             LEAVE_with_name("call_PUSH");
5918             SPAGAIN;
5919             if (gimme == G_ARRAY) {
5920                 I32 i;
5921                 /* EXTEND should not be needed - we just popped them */
5922                 EXTEND(SP, iters);
5923                 for (i=0; i < iters; i++) {
5924                     SV **svp = av_fetch(ary, i, FALSE);
5925                     PUSHs((svp) ? *svp : &PL_sv_undef);
5926                 }
5927                 RETURN;
5928             }
5929         }
5930     }
5931     else {
5932         if (gimme == G_ARRAY)
5933             RETURN;
5934     }
5935
5936     GETTARGET;
5937     PUSHi(iters);
5938     RETURN;
5939 }
5940
5941 PP(pp_once)
5942 {
5943     dSP;
5944     SV *const sv = PAD_SVl(PL_op->op_targ);
5945
5946     if (SvPADSTALE(sv)) {
5947         /* First time. */
5948         SvPADSTALE_off(sv);
5949         RETURNOP(cLOGOP->op_other);
5950     }
5951     RETURNOP(cLOGOP->op_next);
5952 }
5953
5954 PP(pp_lock)
5955 {
5956     dVAR;
5957     dSP;
5958     dTOPss;
5959     SV *retsv = sv;
5960     assert(SvTYPE(retsv) != SVt_PVCV);
5961     SvLOCK(sv);
5962     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
5963         retsv = refto(retsv);
5964     }
5965     SETs(retsv);
5966     RETURN;
5967 }
5968
5969
5970 PP(unimplemented_op)
5971 {
5972     dVAR;
5973     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5974         PL_op->op_type);
5975     return NORMAL;
5976 }
5977
5978 PP(pp_boolkeys)
5979 {
5980     dVAR;
5981     dSP;
5982     HV * const hv = (HV*)POPs;
5983
5984     if (SvRMAGICAL(hv)) {
5985         MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5986         if (mg) {
5987             XPUSHs(magic_scalarpack(hv, mg));
5988             RETURN;
5989         }
5990     }
5991
5992     XPUSHs(boolSV(HvKEYS(hv) != 0));
5993     RETURN;
5994 }
5995
5996 /*
5997  * Local variables:
5998  * c-indentation-style: bsd
5999  * c-basic-offset: 4
6000  * indent-tabs-mode: t
6001  * End:
6002  *
6003  * ex: set ts=8 sts=4 sw=4 noet:
6004  */