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