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