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