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 (PL_op->op_private & OPpLVAL_INTRO)
  72         if (!(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 (PL_op->op_private & OPpLVAL_INTRO)
 122         if (!(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         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 442             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
 443             if (mg && mg->mg_len >= 0) {
 444                 dTARGET;
 445                 I32 i = mg->mg_len;
 446                 if (DO_UTF8(sv))
 447                     sv_pos_b2u(sv, &i);
 448                 PUSHi(i);
 449                 RETURN;
 450             }
 451         }
 452         RETPUSHUNDEF;
 453     }
 454 }
 455
 456 PP(pp_rv2cv)
 457 {
 458     dVAR; dSP;
 459     GV *gv;
 460     HV *stash_unused;
 461     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 462         ? GV_ADDMG
 463         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
 464                                                     == OPpMAY_RETURN_CONSTANT)
 465             ? GV_ADD|GV_NOEXPAND
 466             : GV_ADD;
 467     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 468     /* (But not in defined().) */
 469
 470     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 471     if (cv) NOOP;
 472     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 473         cv = MUTABLE_CV(gv);
 474     }
 475     else
 476         cv = MUTABLE_CV(&PL_sv_undef);
 477     SETs(MUTABLE_SV(cv));
 478     RETURN;
 479 }
 480
 481 PP(pp_prototype)
 482 {
 483     dVAR; dSP;
 484     CV *cv;
 485     HV *stash;
 486     GV *gv;
 487     SV *ret = &PL_sv_undef;
 488
 489     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
 490     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 491         const char * s = SvPVX_const(TOPs);
 492         if (strnEQ(s, "CORE::", 6)) {
 493             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 494             if (!code || code == -KEY_CORE)
 495                 DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
 496                     SVfARG(newSVpvn_flags(
 497                         s+6, SvCUR(TOPs)-6,
 498                         (SvFLAGS(TOPs) & SVf_UTF8)|SVs_TEMP
 499                     )));
 500             {
 501                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 502                 if (sv) ret = sv;
 503             }
 504             goto set;
 505         }
 506     }
 507     cv = sv_2cv(TOPs, &stash, &gv, 0);
 508     if (cv && SvPOK(cv))
 509         ret = newSVpvn_flags(
 510             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 511         );
 512   set:
 513     SETs(ret);
 514     RETURN;
 515 }
 516
 517 PP(pp_anoncode)
 518 {
 519     dVAR; dSP;
 520     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 521     if (CvCLONE(cv))
 522         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 523     EXTEND(SP,1);
 524     PUSHs(MUTABLE_SV(cv));
 525     RETURN;
 526 }
 527
 528 PP(pp_srefgen)
 529 {
 530     dVAR; dSP;
 531     *SP = refto(*SP);
 532     RETURN;
 533 }
 534
 535 PP(pp_refgen)
 536 {
 537     dVAR; dSP; dMARK;
 538     if (GIMME != G_ARRAY) {
 539         if (++MARK <= SP)
 540             *MARK = *SP;
 541         else
 542             *MARK = &PL_sv_undef;
 543         *MARK = refto(*MARK);
 544         SP = MARK;
 545         RETURN;
 546     }
 547     EXTEND_MORTAL(SP - MARK);
 548     while (++MARK <= SP)
 549         *MARK = refto(*MARK);
 550     RETURN;
 551 }
 552
 553 STATIC SV*
 554 S_refto(pTHX_ SV *sv)
 555 {
 556     dVAR;
 557     SV* rv;
 558
 559     PERL_ARGS_ASSERT_REFTO;
 560
 561     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 562         if (LvTARGLEN(sv))
 563             vivify_defelem(sv);
 564         if (!(sv = LvTARG(sv)))
 565             sv = &PL_sv_undef;
 566         else
 567             SvREFCNT_inc_void_NN(sv);
 568     }
 569     else if (SvTYPE(sv) == SVt_PVAV) {
 570         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 571             av_reify(MUTABLE_AV(sv));
 572         SvTEMP_off(sv);
 573         SvREFCNT_inc_void_NN(sv);
 574     }
 575     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 576         sv = newSVsv(sv);
 577     else {
 578         SvTEMP_off(sv);
 579         SvREFCNT_inc_void_NN(sv);
 580     }
 581     rv = sv_newmortal();
 582     sv_upgrade(rv, SVt_IV);
 583     SvRV_set(rv, sv);
 584     SvROK_on(rv);
 585     return rv;
 586 }
 587
 588 PP(pp_ref)
 589 {
 590     dVAR; dSP; dTARGET;
 591     SV * const sv = POPs;
 592
 593     SvGETMAGIC(sv);
 594     if (!SvROK(sv))
 595         RETPUSHNO;
 596
 597     (void)sv_ref(TARG,SvRV(sv),TRUE);
 598     PUSHTARG;
 599     RETURN;
 600 }
 601
 602 PP(pp_bless)
 603 {
 604     dVAR; dSP;
 605     HV *stash;
 606
 607     if (MAXARG == 1)
 608     {
 609       curstash:
 610         stash = CopSTASH(PL_curcop);
 611         if (SvTYPE(stash) != SVt_PVHV)
 612             Perl_croak(aTHX_ "Attempt to bless into a freed package");
 613     }
 614     else {
 615         SV * const ssv = POPs;
 616         STRLEN len;
 617         const char *ptr;
 618
 619         if (!ssv) goto curstash;
 620         if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
 621             Perl_croak(aTHX_ "Attempt to bless into a reference");
 622         ptr = SvPV_const(ssv,len);
 623         if (len == 0)
 624             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 625                            "Explicit blessing to '' (assuming package main)");
 626         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 627     }
 628
 629     (void)sv_bless(TOPs, stash);
 630     RETURN;
 631 }
 632
 633 PP(pp_gelem)
 634 {
 635     dVAR; dSP;
 636
 637     SV *sv = POPs;
 638     STRLEN len;
 639     const char * const elem = SvPV_const(sv, len);
 640     GV * const gv = MUTABLE_GV(POPs);
 641     SV * tmpRef = NULL;
 642
 643     sv = NULL;
 644     if (elem) {
 645         /* elem will always be NUL terminated.  */
 646         const char * const second_letter = elem + 1;
 647         switch (*elem) {
 648         case 'A':
 649             if (len == 5 && strEQ(second_letter, "RRAY"))
 650             {
 651                 tmpRef = MUTABLE_SV(GvAV(gv));
 652                 if (tmpRef && !AvREAL((const AV *)tmpRef)
 653                  && AvREIFY((const AV *)tmpRef))
 654                     av_reify(MUTABLE_AV(tmpRef));
 655             }
 656             break;
 657         case 'C':
 658             if (len == 4 && strEQ(second_letter, "ODE"))
 659                 tmpRef = MUTABLE_SV(GvCVu(gv));
 660             break;
 661         case 'F':
 662             if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
 663                 /* finally deprecated in 5.8.0 */
 664                 deprecate("*glob{FILEHANDLE}");
 665                 tmpRef = MUTABLE_SV(GvIOp(gv));
 666             }
 667             else
 668                 if (len == 6 && strEQ(second_letter, "ORMAT"))
 669                     tmpRef = MUTABLE_SV(GvFORM(gv));
 670             break;
 671         case 'G':
 672             if (len == 4 && strEQ(second_letter, "LOB"))
 673                 tmpRef = MUTABLE_SV(gv);
 674             break;
 675         case 'H':
 676             if (len == 4 && strEQ(second_letter, "ASH"))
 677                 tmpRef = MUTABLE_SV(GvHV(gv));
 678             break;
 679         case 'I':
 680             if (*second_letter == 'O' && !elem[2] && len == 2)
 681                 tmpRef = MUTABLE_SV(GvIOp(gv));
 682             break;
 683         case 'N':
 684             if (len == 4 && strEQ(second_letter, "AME"))
 685                 sv = newSVhek(GvNAME_HEK(gv));
 686             break;
 687         case 'P':
 688             if (len == 7 && strEQ(second_letter, "ACKAGE")) {
 689                 const HV * const stash = GvSTASH(gv);
 690                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 691                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 692             }
 693             break;
 694         case 'S':
 695             if (len == 6 && strEQ(second_letter, "CALAR"))
 696                 tmpRef = GvSVn(gv);
 697             break;
 698         }
 699     }
 700     if (tmpRef)
 701         sv = newRV(tmpRef);
 702     if (sv)
 703         sv_2mortal(sv);
 704     else
 705         sv = &PL_sv_undef;
 706     XPUSHs(sv);
 707     RETURN;
 708 }
 709
 710 /* Pattern matching */
 711
 712 PP(pp_study)
 713 {
 714     dVAR; dSP; dPOPss;
 715     STRLEN len;
 716
 717     (void)SvPV(sv, len);
 718     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 719         /* Historically, study was skipped in these cases. */
 720         RETPUSHNO;
 721     }
 722
 723     /* Make study a no-op. It's no longer useful and its existence
 724        complicates matters elsewhere. */
 725     RETPUSHYES;
 726 }
 727
 728 PP(pp_trans)
 729 {
 730     dVAR; dSP; dTARG;
 731     SV *sv;
 732
 733     if (PL_op->op_flags & OPf_STACKED)
 734         sv = POPs;
 735     else if (PL_op->op_private & OPpTARGET_MY)
 736         sv = GETTARGET;
 737     else {
 738         sv = DEFSV;
 739         EXTEND(SP,1);
 740     }
 741     if(PL_op->op_type == OP_TRANSR) {
 742         STRLEN len;
 743         const char * const pv = SvPV(sv,len);
 744         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 745         do_trans(newsv);
 746         PUSHs(newsv);
 747     }
 748     else {
 749         TARG = sv_newmortal();
 750         PUSHi(do_trans(sv));
 751     }
 752     RETURN;
 753 }
 754
 755 /* Lvalue operators. */
 756
 757 static void
 758 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 759 {
 760     dVAR;
 761     STRLEN len;
 762     char *s;
 763
 764     PERL_ARGS_ASSERT_DO_CHOMP;
 765
 766     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 767         return;
 768     if (SvTYPE(sv) == SVt_PVAV) {
 769         I32 i;
 770         AV *const av = MUTABLE_AV(sv);
 771         const I32 max = AvFILL(av);
 772
 773         for (i = 0; i <= max; i++) {
 774             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 775             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 776                 do_chomp(retval, sv, chomping);
 777         }
 778         return;
 779     }
 780     else if (SvTYPE(sv) == SVt_PVHV) {
 781         HV* const hv = MUTABLE_HV(sv);
 782         HE* entry;
 783         (void)hv_iterinit(hv);
 784         while ((entry = hv_iternext(hv)))
 785             do_chomp(retval, hv_iterval(hv,entry), chomping);
 786         return;
 787     }
 788     else if (SvREADONLY(sv)) {
 789             Perl_croak_no_modify();
 790     }
 791     else if (SvIsCOW(sv)) {
 792         sv_force_normal_flags(sv, 0);
 793     }
 794
 795     if (PL_encoding) {
 796         if (!SvUTF8(sv)) {
 797             /* XXX, here sv is utf8-ized as a side-effect!
 798                If encoding.pm is used properly, almost string-generating
 799                operations, including literal strings, chr(), input data, etc.
 800                should have been utf8-ized already, right?
 801             */
 802             sv_recode_to_utf8(sv, PL_encoding);
 803         }
 804     }
 805
 806     s = SvPV(sv, len);
 807     if (chomping) {
 808         char *temp_buffer = NULL;
 809         SV *svrecode = NULL;
 810
 811         if (s && len) {
 812             s += --len;
 813             if (RsPARA(PL_rs)) {
 814                 if (*s != '\n')
 815                     goto nope;
 816                 ++SvIVX(retval);
 817                 while (len && s[-1] == '\n') {
 818                     --len;
 819                     --s;
 820                     ++SvIVX(retval);
 821                 }
 822             }
 823             else {
 824                 STRLEN rslen, rs_charlen;
 825                 const char *rsptr = SvPV_const(PL_rs, rslen);
 826
 827                 rs_charlen = SvUTF8(PL_rs)
 828                     ? sv_len_utf8(PL_rs)
 829                     : rslen;
 830
 831                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 832                     /* Assumption is that rs is shorter than the scalar.  */
 833                     if (SvUTF8(PL_rs)) {
 834                         /* RS is utf8, scalar is 8 bit.  */
 835                         bool is_utf8 = TRUE;
 836                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 837                                                              &rslen, &is_utf8);
 838                         if (is_utf8) {
 839                             /* Cannot downgrade, therefore cannot possibly match
 840                              */
 841                             assert (temp_buffer == rsptr);
 842                             temp_buffer = NULL;
 843                             goto nope;
 844                         }
 845                         rsptr = temp_buffer;
 846                     }
 847                     else if (PL_encoding) {
 848                         /* RS is 8 bit, encoding.pm is used.
 849                          * Do not recode PL_rs as a side-effect. */
 850                         svrecode = newSVpvn(rsptr, rslen);
 851                         sv_recode_to_utf8(svrecode, PL_encoding);
 852                         rsptr = SvPV_const(svrecode, rslen);
 853                         rs_charlen = sv_len_utf8(svrecode);
 854                     }
 855                     else {
 856                         /* RS is 8 bit, scalar is utf8.  */
 857                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 858                         rsptr = temp_buffer;
 859                     }
 860                 }
 861                 if (rslen == 1) {
 862                     if (*s != *rsptr)
 863                         goto nope;
 864                     ++SvIVX(retval);
 865                 }
 866                 else {
 867                     if (len < rslen - 1)
 868                         goto nope;
 869                     len -= rslen - 1;
 870                     s -= rslen - 1;
 871                     if (memNE(s, rsptr, rslen))
 872                         goto nope;
 873                     SvIVX(retval) += rs_charlen;
 874                 }
 875             }
 876             s = SvPV_force_nomg_nolen(sv);
 877             SvCUR_set(sv, len);
 878             *SvEND(sv) = '\0';
 879             SvNIOK_off(sv);
 880             SvSETMAGIC(sv);
 881         }
 882     nope:
 883
 884         SvREFCNT_dec(svrecode);
 885
 886         Safefree(temp_buffer);
 887     } else {
 888         if (len && !SvPOK(sv))
 889             s = SvPV_force_nomg(sv, len);
 890         if (DO_UTF8(sv)) {
 891             if (s && len) {
 892                 char * const send = s + len;
 893                 char * const start = s;
 894                 s = send - 1;
 895                 while (s > start && UTF8_IS_CONTINUATION(*s))
 896                     s--;
 897                 if (is_utf8_string((U8*)s, send - s)) {
 898                     sv_setpvn(retval, s, send - s);
 899                     *s = '\0';
 900                     SvCUR_set(sv, s - start);
 901                     SvNIOK_off(sv);
 902                     SvUTF8_on(retval);
 903                 }
 904             }
 905             else
 906                 sv_setpvs(retval, "");
 907         }
 908         else if (s && len) {
 909             s += --len;
 910             sv_setpvn(retval, s, 1);
 911             *s = '\0';
 912             SvCUR_set(sv, len);
 913             SvUTF8_off(sv);
 914             SvNIOK_off(sv);
 915         }
 916         else
 917             sv_setpvs(retval, "");
 918         SvSETMAGIC(sv);
 919     }
 920 }
 921
 922 PP(pp_schop)
 923 {
 924     dVAR; dSP; dTARGET;
 925     const bool chomping = PL_op->op_type == OP_SCHOMP;
 926
 927     if (chomping)
 928         sv_setiv(TARG, 0);
 929     do_chomp(TARG, TOPs, chomping);
 930     SETTARG;
 931     RETURN;
 932 }
 933
 934 PP(pp_chop)
 935 {
 936     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
 937     const bool chomping = PL_op->op_type == OP_CHOMP;
 938
 939     if (chomping)
 940         sv_setiv(TARG, 0);
 941     while (MARK < SP)
 942         do_chomp(TARG, *++MARK, chomping);
 943     SP = ORIGMARK;
 944     XPUSHTARG;
 945     RETURN;
 946 }
 947
 948 PP(pp_undef)
 949 {
 950     dVAR; dSP;
 951     SV *sv;
 952
 953     if (!PL_op->op_private) {
 954         EXTEND(SP, 1);
 955         RETPUSHUNDEF;
 956     }
 957
 958     sv = POPs;
 959     if (!sv)
 960         RETPUSHUNDEF;
 961
 962     SV_CHECK_THINKFIRST_COW_DROP(sv);
 963
 964     switch (SvTYPE(sv)) {
 965     case SVt_NULL:
 966         break;
 967     case SVt_PVAV:
 968         av_undef(MUTABLE_AV(sv));
 969         break;
 970     case SVt_PVHV:
 971         hv_undef(MUTABLE_HV(sv));
 972         break;
 973     case SVt_PVCV:
 974         if (cv_const_sv((const CV *)sv))
 975             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 976                           "Constant subroutine %"SVf" undefined",
 977                            SVfARG(CvANON((const CV *)sv)
 978                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
 979                              : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
 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+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 * UTF8_MAX_FOLD_CHAR_EXPAND + 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 (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 (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 = (HV *)sv_2mortal((SV *)newHV());
4831
4832     while (MARK < SP) {
4833         SV * const key =
4834             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4835         SV *val;
4836         if (MARK < SP)
4837         {
4838             MARK++;
4839             SvGETMAGIC(*MARK);
4840             val = newSV(0);
4841             sv_setsv(val, *MARK);
4842         }
4843         else
4844         {
4845             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4846             val = newSV(0);
4847         }
4848         (void)hv_store_ent(hv,key,val,0);
4849     }
4850     SP = ORIGMARK;
4851     if (PL_op->op_flags & OPf_SPECIAL)
4852         mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
4853     else XPUSHs(MUTABLE_SV(hv));
4854     RETURN;
4855 }
4856
4857 static AV *
4858 S_deref_plain_array(pTHX_ AV *ary)
4859 {
4860     if (SvTYPE(ary) == SVt_PVAV) return ary;
4861     SvGETMAGIC((SV *)ary);
4862     if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4863         Perl_die(aTHX_ "Not an ARRAY reference");
4864     else if (SvOBJECT(SvRV(ary)))
4865         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4866     return (AV *)SvRV(ary);
4867 }
4868
4869 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4870 # define DEREF_PLAIN_ARRAY(ary)       \
4871    ({                                  \
4872      AV *aRrRay = ary;                  \
4873      SvTYPE(aRrRay) == SVt_PVAV          \
4874       ? aRrRay                            \
4875       : S_deref_plain_array(aTHX_ aRrRay); \
4876    })
4877 #else
4878 # define DEREF_PLAIN_ARRAY(ary)            \
4879    (                                        \
4880      PL_Sv = (SV *)(ary),                    \
4881      SvTYPE(PL_Sv) == SVt_PVAV                \
4882       ? (AV *)PL_Sv                            \
4883       : S_deref_plain_array(aTHX_ (AV *)PL_Sv)  \
4884    )
4885 #endif
4886
4887 PP(pp_splice)
4888 {
4889     dVAR; dSP; dMARK; dORIGMARK;
4890     int num_args = (SP - MARK);
4891     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4892     SV **src;
4893     SV **dst;
4894     I32 i;
4895     I32 offset;
4896     I32 length;
4897     I32 newlen;
4898     I32 after;
4899     I32 diff;
4900     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4901
4902     if (mg) {
4903         return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4904                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4905                                     sp - mark);
4906     }
4907
4908     SP++;
4909
4910     if (++MARK < SP) {
4911         offset = i = SvIV(*MARK);
4912         if (offset < 0)
4913             offset += AvFILLp(ary) + 1;
4914         if (offset < 0)
4915             DIE(aTHX_ PL_no_aelem, i);
4916         if (++MARK < SP) {
4917             length = SvIVx(*MARK++);
4918             if (length < 0) {
4919                 length += AvFILLp(ary) - offset + 1;
4920                 if (length < 0)
4921                     length = 0;
4922             }
4923         }
4924         else
4925             length = AvMAX(ary) + 1;            /* close enough to infinity */
4926     }
4927     else {
4928         offset = 0;
4929         length = AvMAX(ary) + 1;
4930     }
4931     if (offset > AvFILLp(ary) + 1) {
4932         if (num_args > 2)
4933             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4934         offset = AvFILLp(ary) + 1;
4935     }
4936     after = AvFILLp(ary) + 1 - (offset + length);
4937     if (after < 0) {                            /* not that much array */
4938         length += after;                        /* offset+length now in array */
4939         after = 0;
4940         if (!AvALLOC(ary))
4941             av_extend(ary, 0);
4942     }
4943
4944     /* At this point, MARK .. SP-1 is our new LIST */
4945
4946     newlen = SP - MARK;
4947     diff = newlen - length;
4948     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4949         av_reify(ary);
4950
4951     /* make new elements SVs now: avoid problems if they're from the array */
4952     for (dst = MARK, i = newlen; i; i--) {
4953         SV * const h = *dst;
4954         *dst++ = newSVsv(h);
4955     }
4956
4957     if (diff < 0) {                             /* shrinking the area */
4958         SV **tmparyval = NULL;
4959         if (newlen) {
4960             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4961             Copy(MARK, tmparyval, newlen, SV*);
4962         }
4963
4964         MARK = ORIGMARK + 1;
4965         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4966             MEXTEND(MARK, length);
4967             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4968             if (AvREAL(ary)) {
4969                 EXTEND_MORTAL(length);
4970                 for (i = length, dst = MARK; i; i--) {
4971                     sv_2mortal(*dst);   /* free them eventually */
4972                     dst++;
4973                 }
4974             }
4975             MARK += length - 1;
4976         }
4977         else {
4978             *MARK = AvARRAY(ary)[offset+length-1];
4979             if (AvREAL(ary)) {
4980                 sv_2mortal(*MARK);
4981                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4982                     SvREFCNT_dec(*dst++);       /* free them now */
4983             }
4984         }
4985         AvFILLp(ary) += diff;
4986
4987         /* pull up or down? */
4988
4989         if (offset < after) {                   /* easier to pull up */
4990             if (offset) {                       /* esp. if nothing to pull */
4991                 src = &AvARRAY(ary)[offset-1];
4992                 dst = src - diff;               /* diff is negative */
4993                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4994                     *dst-- = *src--;
4995             }
4996             dst = AvARRAY(ary);
4997             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4998             AvMAX(ary) += diff;
4999         }
5000         else {
5001             if (after) {                        /* anything to pull down? */
5002                 src = AvARRAY(ary) + offset + length;
5003                 dst = src + diff;               /* diff is negative */
5004                 Move(src, dst, after, SV*);
5005             }
5006             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5007                                                 /* avoid later double free */
5008         }
5009         i = -diff;
5010         while (i)
5011             dst[--i] = &PL_sv_undef;
5012
5013         if (newlen) {
5014             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5015             Safefree(tmparyval);
5016         }
5017     }
5018     else {                                      /* no, expanding (or same) */
5019         SV** tmparyval = NULL;
5020         if (length) {
5021             Newx(tmparyval, length, SV*);       /* so remember deletion */
5022             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5023         }
5024
5025         if (diff > 0) {                         /* expanding */
5026             /* push up or down? */
5027             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5028                 if (offset) {
5029                     src = AvARRAY(ary);
5030                     dst = src - diff;
5031                     Move(src, dst, offset, SV*);
5032                 }
5033                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5034                 AvMAX(ary) += diff;
5035                 AvFILLp(ary) += diff;
5036             }
5037             else {
5038                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5039                     av_extend(ary, AvFILLp(ary) + diff);
5040                 AvFILLp(ary) += diff;
5041
5042                 if (after) {
5043                     dst = AvARRAY(ary) + AvFILLp(ary);
5044                     src = dst - diff;
5045                     for (i = after; i; i--) {
5046                         *dst-- = *src--;
5047                     }
5048                 }
5049             }
5050         }
5051
5052         if (newlen) {
5053             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5054         }
5055
5056         MARK = ORIGMARK + 1;
5057         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5058             if (length) {
5059                 Copy(tmparyval, MARK, length, SV*);
5060                 if (AvREAL(ary)) {
5061                     EXTEND_MORTAL(length);
5062                     for (i = length, dst = MARK; i; i--) {
5063                         sv_2mortal(*dst);       /* free them eventually */
5064                         dst++;
5065                     }
5066                 }
5067             }
5068             MARK += length - 1;
5069         }
5070         else if (length--) {
5071             *MARK = tmparyval[length];
5072             if (AvREAL(ary)) {
5073                 sv_2mortal(*MARK);
5074                 while (length-- > 0)
5075                     SvREFCNT_dec(tmparyval[length]);
5076             }
5077         }
5078         else
5079             *MARK = &PL_sv_undef;
5080         Safefree(tmparyval);
5081     }
5082
5083     if (SvMAGICAL(ary))
5084         mg_set(MUTABLE_SV(ary));
5085
5086     SP = MARK;
5087     RETURN;
5088 }
5089
5090 PP(pp_push)
5091 {
5092     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5093     AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5094     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5095
5096     if (mg) {
5097         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5098         PUSHMARK(MARK);
5099         PUTBACK;
5100         ENTER_with_name("call_PUSH");
5101         call_method("PUSH",G_SCALAR|G_DISCARD);
5102         LEAVE_with_name("call_PUSH");
5103         SPAGAIN;
5104     }
5105     else {
5106         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5107         PL_delaymagic = DM_DELAY;
5108         for (++MARK; MARK <= SP; MARK++) {
5109             SV *sv;
5110             if (*MARK) SvGETMAGIC(*MARK);
5111             sv = newSV(0);
5112             if (*MARK)
5113                 sv_setsv_nomg(sv, *MARK);
5114             av_store(ary, AvFILLp(ary)+1, sv);
5115         }
5116         if (PL_delaymagic & DM_ARRAY_ISA)
5117             mg_set(MUTABLE_SV(ary));
5118
5119         PL_delaymagic = 0;
5120     }
5121     SP = ORIGMARK;
5122     if (OP_GIMME(PL_op, 0) != G_VOID) {
5123         PUSHi( AvFILL(ary) + 1 );
5124     }
5125     RETURN;
5126 }
5127
5128 PP(pp_shift)
5129 {
5130     dVAR;
5131     dSP;
5132     AV * const av = PL_op->op_flags & OPf_SPECIAL
5133         ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5134     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5135     EXTEND(SP, 1);
5136     assert (sv);
5137     if (AvREAL(av))
5138         (void)sv_2mortal(sv);
5139     PUSHs(sv);
5140     RETURN;
5141 }
5142
5143 PP(pp_unshift)
5144 {
5145     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5146     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5147     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5148
5149     if (mg) {
5150         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5151         PUSHMARK(MARK);
5152         PUTBACK;
5153         ENTER_with_name("call_UNSHIFT");
5154         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5155         LEAVE_with_name("call_UNSHIFT");
5156         SPAGAIN;
5157     }
5158     else {
5159         I32 i = 0;
5160         av_unshift(ary, SP - MARK);
5161         while (MARK < SP) {
5162             SV * const sv = newSVsv(*++MARK);
5163             (void)av_store(ary, i++, sv);
5164         }
5165     }
5166     SP = ORIGMARK;
5167     if (OP_GIMME(PL_op, 0) != G_VOID) {
5168         PUSHi( AvFILL(ary) + 1 );
5169     }
5170     RETURN;
5171 }
5172
5173 PP(pp_reverse)
5174 {
5175     dVAR; dSP; dMARK;
5176
5177     if (GIMME == G_ARRAY) {
5178         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5179             AV *av;
5180
5181             /* See pp_sort() */
5182             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5183             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5184             av = MUTABLE_AV((*SP));
5185             /* In-place reversing only happens in void context for the array
5186              * assignment. We don't need to push anything on the stack. */
5187             SP = MARK;
5188
5189             if (SvMAGICAL(av)) {
5190                 I32 i, j;
5191                 SV *tmp = sv_newmortal();
5192                 /* For SvCANEXISTDELETE */
5193                 HV *stash;
5194                 const MAGIC *mg;
5195                 bool can_preserve = SvCANEXISTDELETE(av);
5196
5197                 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5198                     SV *begin, *end;
5199
5200                     if (can_preserve) {
5201                         if (!av_exists(av, i)) {
5202                             if (av_exists(av, j)) {
5203                                 SV *sv = av_delete(av, j, 0);
5204                                 begin = *av_fetch(av, i, TRUE);
5205                                 sv_setsv_mg(begin, sv);
5206                             }
5207                             continue;
5208                         }
5209                         else if (!av_exists(av, j)) {
5210                             SV *sv = av_delete(av, i, 0);
5211                             end = *av_fetch(av, j, TRUE);
5212                             sv_setsv_mg(end, sv);
5213                             continue;
5214                         }
5215                     }
5216
5217                     begin = *av_fetch(av, i, TRUE);
5218                     end   = *av_fetch(av, j, TRUE);
5219                     sv_setsv(tmp,      begin);
5220                     sv_setsv_mg(begin, end);
5221                     sv_setsv_mg(end,   tmp);
5222                 }
5223             }
5224             else {
5225                 SV **begin = AvARRAY(av);
5226
5227                 if (begin) {
5228                     SV **end   = begin + AvFILLp(av);
5229
5230                     while (begin < end) {
5231                         SV * const tmp = *begin;
5232                         *begin++ = *end;
5233                         *end--   = tmp;
5234                     }
5235                 }
5236             }
5237         }
5238         else {
5239             SV **oldsp = SP;
5240             MARK++;
5241             while (MARK < SP) {
5242                 SV * const tmp = *MARK;
5243                 *MARK++ = *SP;
5244                 *SP--   = tmp;
5245             }
5246             /* safe as long as stack cannot get extended in the above */
5247             SP = oldsp;
5248         }
5249     }
5250     else {
5251         char *up;
5252         char *down;
5253         I32 tmp;
5254         dTARGET;
5255         STRLEN len;
5256
5257         SvUTF8_off(TARG);                               /* decontaminate */
5258         if (SP - MARK > 1)
5259             do_join(TARG, &PL_sv_no, MARK, SP);
5260         else {
5261             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5262             if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5263                 report_uninit(TARG);
5264         }
5265
5266         up = SvPV_force(TARG, len);
5267         if (len > 1) {
5268             if (DO_UTF8(TARG)) {        /* first reverse each character */
5269                 U8* s = (U8*)SvPVX(TARG);
5270                 const U8* send = (U8*)(s + len);
5271                 while (s < send) {
5272                     if (UTF8_IS_INVARIANT(*s)) {
5273                         s++;
5274                         continue;
5275                     }
5276                     else {
5277                         if (!utf8_to_uvchr_buf(s, send, 0))
5278                             break;
5279                         up = (char*)s;
5280                         s += UTF8SKIP(s);
5281                         down = (char*)(s - 1);
5282                         /* reverse this character */
5283                         while (down > up) {
5284                             tmp = *up;
5285                             *up++ = *down;
5286                             *down-- = (char)tmp;
5287                         }
5288                     }
5289                 }
5290                 up = SvPVX(TARG);
5291             }
5292             down = SvPVX(TARG) + len - 1;
5293             while (down > up) {
5294                 tmp = *up;
5295                 *up++ = *down;
5296                 *down-- = (char)tmp;
5297             }
5298             (void)SvPOK_only_UTF8(TARG);
5299         }
5300         SP = MARK + 1;
5301         SETTARG;
5302     }
5303     RETURN;
5304 }
5305
5306 PP(pp_split)
5307 {
5308     dVAR; dSP; dTARG;
5309     AV *ary;
5310     IV limit = POPi;                    /* note, negative is forever */
5311     SV * const sv = POPs;
5312     STRLEN len;
5313     const char *s = SvPV_const(sv, len);
5314     const bool do_utf8 = DO_UTF8(sv);
5315     const char *strend = s + len;
5316     PMOP *pm;
5317     REGEXP *rx;
5318     SV *dstr;
5319     const char *m;
5320     I32 iters = 0;
5321     const STRLEN slen = do_utf8
5322                         ? utf8_length((U8*)s, (U8*)strend)
5323                         : (STRLEN)(strend - s);
5324     I32 maxiters = slen + 10;
5325     I32 trailing_empty = 0;
5326     const char *orig;
5327     const I32 origlimit = limit;
5328     I32 realarray = 0;
5329     I32 base;
5330     const I32 gimme = GIMME_V;
5331     bool gimme_scalar;
5332     const I32 oldsave = PL_savestack_ix;
5333     U32 make_mortal = SVs_TEMP;
5334     bool multiline = 0;
5335     MAGIC *mg = NULL;
5336
5337 #ifdef DEBUGGING
5338     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5339 #else
5340     pm = (PMOP*)POPs;
5341 #endif
5342     if (!pm || !s)
5343         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5344     rx = PM_GETRE(pm);
5345
5346     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5347              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5348
5349 #ifdef USE_ITHREADS
5350     if (pm->op_pmreplrootu.op_pmtargetoff) {
5351         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5352     }
5353 #else
5354     if (pm->op_pmreplrootu.op_pmtargetgv) {
5355         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5356     }
5357 #endif
5358     else
5359         ary = NULL;
5360     if (ary) {
5361         realarray = 1;
5362         PUTBACK;
5363         av_extend(ary,0);
5364         av_clear(ary);
5365         SPAGAIN;
5366         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5367             PUSHMARK(SP);
5368             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5369         }
5370         else {
5371             if (!AvREAL(ary)) {
5372                 I32 i;
5373                 AvREAL_on(ary);
5374                 AvREIFY_off(ary);
5375                 for (i = AvFILLp(ary); i >= 0; i--)
5376                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5377             }
5378             /* temporarily switch stacks */
5379             SAVESWITCHSTACK(PL_curstack, ary);
5380             make_mortal = 0;
5381         }
5382     }
5383     base = SP - PL_stack_base;
5384     orig = s;
5385     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5386         if (do_utf8) {
5387             while (isSPACE_utf8(s))
5388                 s += UTF8SKIP(s);
5389         }
5390         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5391             while (isSPACE_LC(*s))
5392                 s++;
5393         }
5394         else {
5395             while (isSPACE(*s))
5396                 s++;
5397         }
5398     }
5399     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5400         multiline = 1;
5401     }
5402
5403     gimme_scalar = gimme == G_SCALAR && !ary;
5404
5405     if (!limit)
5406         limit = maxiters + 2;
5407     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5408         while (--limit) {
5409             m = s;
5410             /* this one uses 'm' and is a negative test */
5411             if (do_utf8) {
5412                 while (m < strend && ! isSPACE_utf8(m) ) {
5413                     const int t = UTF8SKIP(m);
5414                     /* isSPACE_utf8 returns FALSE for malform utf8 */
5415                     if (strend - m < t)
5416                         m = strend;
5417                     else
5418                         m += t;
5419                 }
5420             }
5421             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5422             {
5423                 while (m < strend && !isSPACE_LC(*m))
5424                     ++m;
5425             } else {
5426                 while (m < strend && !isSPACE(*m))
5427                     ++m;
5428             }
5429             if (m >= strend)
5430                 break;
5431
5432             if (gimme_scalar) {
5433                 iters++;
5434                 if (m-s == 0)
5435                     trailing_empty++;
5436                 else
5437                     trailing_empty = 0;
5438             } else {
5439                 dstr = newSVpvn_flags(s, m-s,
5440                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5441                 XPUSHs(dstr);
5442             }
5443
5444             /* skip the whitespace found last */
5445             if (do_utf8)
5446                 s = m + UTF8SKIP(m);
5447             else
5448                 s = m + 1;
5449
5450             /* this one uses 's' and is a positive test */
5451             if (do_utf8) {
5452                 while (s < strend && isSPACE_utf8(s) )
5453                     s +=  UTF8SKIP(s);
5454             }
5455             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5456             {
5457                 while (s < strend && isSPACE_LC(*s))
5458                     ++s;
5459             } else {
5460                 while (s < strend && isSPACE(*s))
5461                     ++s;
5462             }
5463         }
5464     }
5465     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5466         while (--limit) {
5467             for (m = s; m < strend && *m != '\n'; m++)
5468                 ;
5469             m++;
5470             if (m >= strend)
5471                 break;
5472
5473             if (gimme_scalar) {
5474                 iters++;
5475                 if (m-s == 0)
5476                     trailing_empty++;
5477                 else
5478                     trailing_empty = 0;
5479             } else {
5480                 dstr = newSVpvn_flags(s, m-s,
5481                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5482                 XPUSHs(dstr);
5483             }
5484             s = m;
5485         }
5486     }
5487     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5488         /*
5489           Pre-extend the stack, either the number of bytes or
5490           characters in the string or a limited amount, triggered by:
5491
5492           my ($x, $y) = split //, $str;
5493             or
5494           split //, $str, $i;
5495         */
5496         if (!gimme_scalar) {
5497             const U32 items = limit - 1;
5498             if (items < slen)
5499                 EXTEND(SP, items);
5500             else
5501                 EXTEND(SP, slen);
5502         }
5503
5504         if (do_utf8) {
5505             while (--limit) {
5506                 /* keep track of how many bytes we skip over */
5507                 m = s;
5508                 s += UTF8SKIP(s);
5509                 if (gimme_scalar) {
5510                     iters++;
5511                     if (s-m == 0)
5512                         trailing_empty++;
5513                     else
5514                         trailing_empty = 0;
5515                 } else {
5516                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5517
5518                     PUSHs(dstr);
5519                 }
5520
5521                 if (s >= strend)
5522                     break;
5523             }
5524         } else {
5525             while (--limit) {
5526                 if (gimme_scalar) {
5527                     iters++;
5528                 } else {
5529                     dstr = newSVpvn(s, 1);
5530
5531
5532                     if (make_mortal)
5533                         sv_2mortal(dstr);
5534
5535                     PUSHs(dstr);
5536                 }
5537
5538                 s++;
5539
5540                 if (s >= strend)
5541                     break;
5542             }
5543         }
5544     }
5545     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5546              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5547              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5548              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5549         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5550         SV * const csv = CALLREG_INTUIT_STRING(rx);
5551
5552         len = RX_MINLENRET(rx);
5553         if (len == 1 && !RX_UTF8(rx) && !tail) {
5554             const char c = *SvPV_nolen_const(csv);
5555             while (--limit) {
5556                 for (m = s; m < strend && *m != c; m++)
5557                     ;
5558                 if (m >= strend)
5559                     break;
5560                 if (gimme_scalar) {
5561                     iters++;
5562                     if (m-s == 0)
5563                         trailing_empty++;
5564                     else
5565                         trailing_empty = 0;
5566                 } else {
5567                     dstr = newSVpvn_flags(s, m-s,
5568                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5569                     XPUSHs(dstr);
5570                 }
5571                 /* The rx->minlen is in characters but we want to step
5572                  * s ahead by bytes. */
5573                 if (do_utf8)
5574                     s = (char*)utf8_hop((U8*)m, len);
5575                 else
5576                     s = m + len; /* Fake \n at the end */
5577             }
5578         }
5579         else {
5580             while (s < strend && --limit &&
5581               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5582                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5583             {
5584                 if (gimme_scalar) {
5585                     iters++;
5586                     if (m-s == 0)
5587                         trailing_empty++;
5588                     else
5589                         trailing_empty = 0;
5590                 } else {
5591                     dstr = newSVpvn_flags(s, m-s,
5592                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5593                     XPUSHs(dstr);
5594                 }
5595                 /* The rx->minlen is in characters but we want to step
5596                  * s ahead by bytes. */
5597                 if (do_utf8)
5598                     s = (char*)utf8_hop((U8*)m, len);
5599                 else
5600                     s = m + len; /* Fake \n at the end */
5601             }
5602         }
5603     }
5604     else {
5605         maxiters += slen * RX_NPARENS(rx);
5606         while (s < strend && --limit)
5607         {
5608             I32 rex_return;
5609             PUTBACK;
5610             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5611                                      sv, NULL, 0);
5612             SPAGAIN;
5613             if (rex_return == 0)
5614                 break;
5615             TAINT_IF(RX_MATCH_TAINTED(rx));
5616             /* we never pass the REXEC_COPY_STR flag, so it should
5617              * never get copied */
5618             assert(!RX_MATCH_COPIED(rx));
5619             m = RX_OFFS(rx)[0].start + orig;
5620
5621             if (gimme_scalar) {
5622                 iters++;
5623                 if (m-s == 0)
5624                     trailing_empty++;
5625                 else
5626                     trailing_empty = 0;
5627             } else {
5628                 dstr = newSVpvn_flags(s, m-s,
5629                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5630                 XPUSHs(dstr);
5631             }
5632             if (RX_NPARENS(rx)) {
5633                 I32 i;
5634                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5635                     s = RX_OFFS(rx)[i].start + orig;
5636                     m = RX_OFFS(rx)[i].end + orig;
5637
5638                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5639                        parens that didn't match -- they should be set to
5640                        undef, not the empty string */
5641                     if (gimme_scalar) {
5642                         iters++;
5643                         if (m-s == 0)
5644                             trailing_empty++;
5645                         else
5646                             trailing_empty = 0;
5647                     } else {
5648                         if (m >= orig && s >= orig) {
5649                             dstr = newSVpvn_flags(s, m-s,
5650                                                  (do_utf8 ? SVf_UTF8 : 0)
5651                                                   | make_mortal);
5652                         }
5653                         else
5654                             dstr = &PL_sv_undef;  /* undef, not "" */
5655                         XPUSHs(dstr);
5656                     }
5657
5658                 }
5659             }
5660             s = RX_OFFS(rx)[0].end + orig;
5661         }
5662     }
5663
5664     if (!gimme_scalar) {
5665         iters = (SP - PL_stack_base) - base;
5666     }
5667     if (iters > maxiters)
5668         DIE(aTHX_ "Split loop");
5669
5670     /* keep field after final delim? */
5671     if (s < strend || (iters && origlimit)) {
5672         if (!gimme_scalar) {
5673             const STRLEN l = strend - s;
5674             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5675             XPUSHs(dstr);
5676         }
5677         iters++;
5678     }
5679     else if (!origlimit) {
5680         if (gimme_scalar) {
5681             iters -= trailing_empty;
5682         } else {
5683             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5684                 if (TOPs && !make_mortal)
5685                     sv_2mortal(TOPs);
5686                 *SP-- = &PL_sv_undef;
5687                 iters--;
5688             }
5689         }
5690     }
5691
5692     PUTBACK;
5693     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5694     SPAGAIN;
5695     if (realarray) {
5696         if (!mg) {
5697             if (SvSMAGICAL(ary)) {
5698                 PUTBACK;
5699                 mg_set(MUTABLE_SV(ary));
5700                 SPAGAIN;
5701             }
5702             if (gimme == G_ARRAY) {
5703                 EXTEND(SP, iters);
5704                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5705                 SP += iters;
5706                 RETURN;
5707             }
5708         }
5709         else {
5710             PUTBACK;
5711             ENTER_with_name("call_PUSH");
5712             call_method("PUSH",G_SCALAR|G_DISCARD);
5713             LEAVE_with_name("call_PUSH");
5714             SPAGAIN;
5715             if (gimme == G_ARRAY) {
5716                 I32 i;
5717                 /* EXTEND should not be needed - we just popped them */
5718                 EXTEND(SP, iters);
5719                 for (i=0; i < iters; i++) {
5720                     SV **svp = av_fetch(ary, i, FALSE);
5721                     PUSHs((svp) ? *svp : &PL_sv_undef);
5722                 }
5723                 RETURN;
5724             }
5725         }
5726     }
5727     else {
5728         if (gimme == G_ARRAY)
5729             RETURN;
5730     }
5731
5732     GETTARGET;
5733     PUSHi(iters);
5734     RETURN;
5735 }
5736
5737 PP(pp_once)
5738 {
5739     dSP;
5740     SV *const sv = PAD_SVl(PL_op->op_targ);
5741
5742     if (SvPADSTALE(sv)) {
5743         /* First time. */
5744         SvPADSTALE_off(sv);
5745         RETURNOP(cLOGOP->op_other);
5746     }
5747     RETURNOP(cLOGOP->op_next);
5748 }
5749
5750 PP(pp_lock)
5751 {
5752     dVAR;
5753     dSP;
5754     dTOPss;
5755     SV *retsv = sv;
5756     SvLOCK(sv);
5757     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5758      || SvTYPE(retsv) == SVt_PVCV) {
5759         retsv = refto(retsv);
5760     }
5761     SETs(retsv);
5762     RETURN;
5763 }
5764
5765
5766 PP(unimplemented_op)
5767 {
5768     dVAR;
5769     const Optype op_type = PL_op->op_type;
5770     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5771        with out of range op numbers - it only "special" cases op_custom.
5772        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5773        if we get here for a custom op then that means that the custom op didn't
5774        have an implementation. Given that OP_NAME() looks up the custom op
5775        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5776        registers &PL_unimplemented_op as the address of their custom op.
5777        NULL doesn't generate a useful error message. "custom" does. */
5778     const char *const name = op_type >= OP_max
5779         ? "[out of range]" : PL_op_name[PL_op->op_type];
5780     if(OP_IS_SOCKET(op_type))
5781         DIE(aTHX_ PL_no_sock_func, name);
5782     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
5783 }
5784
5785 /* For sorting out arguments passed to a &CORE:: subroutine */
5786 PP(pp_coreargs)
5787 {
5788     dSP;
5789     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5790     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5791     AV * const at_ = GvAV(PL_defgv);
5792     SV **svp = at_ ? AvARRAY(at_) : NULL;
5793     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5794     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5795     bool seen_question = 0;
5796     const char *err = NULL;
5797     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5798
5799     /* Count how many args there are first, to get some idea how far to
5800        extend the stack. */
5801     while (oa) {
5802         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5803         maxargs++;
5804         if (oa & OA_OPTIONAL) seen_question = 1;
5805         if (!seen_question) minargs++;
5806         oa >>= 4;
5807     }
5808
5809     if(numargs < minargs) err = "Not enough";
5810     else if(numargs > maxargs) err = "Too many";
5811     if (err)
5812         /* diag_listed_as: Too many arguments for %s */
5813         Perl_croak(aTHX_
5814           "%s arguments for %s", err,
5815            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5816         );
5817
5818     /* Reset the stack pointer.  Without this, we end up returning our own
5819        arguments in list context, in addition to the values we are supposed
5820        to return.  nextstate usually does this on sub entry, but we need
5821        to run the next op with the caller's hints, so we cannot have a
5822        nextstate. */
5823     SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5824
5825     if(!maxargs) RETURN;
5826
5827     /* We do this here, rather than with a separate pushmark op, as it has
5828        to come in between two things this function does (stack reset and
5829        arg pushing).  This seems the easiest way to do it. */
5830     if (pushmark) {
5831         PUTBACK;
5832         (void)Perl_pp_pushmark(aTHX);
5833     }
5834
5835     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5836     PUTBACK; /* The code below can die in various places. */
5837
5838     oa = PL_opargs[opnum] >> OASHIFT;
5839     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5840         whicharg++;
5841         switch (oa & 7) {
5842         case OA_SCALAR:
5843           try_defsv:
5844             if (!numargs && defgv && whicharg == minargs + 1) {
5845                 PUSHs(find_rundefsv2(
5846                     find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5847                     cxstack[cxstack_ix].blk_oldcop->cop_seq
5848                 ));
5849             }
5850             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5851             break;
5852         case OA_LIST:
5853             while (numargs--) {
5854                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5855                 svp++;
5856             }
5857             RETURN;
5858         case OA_HVREF:
5859             if (!svp || !*svp || !SvROK(*svp)
5860              || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5861                 DIE(aTHX_
5862                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5863                  "Type of arg %d to &CORE::%s must be hash reference",
5864                   whicharg, OP_DESC(PL_op->op_next)
5865                 );
5866             PUSHs(SvRV(*svp));
5867             break;
5868         case OA_FILEREF:
5869             if (!numargs) PUSHs(NULL);
5870             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5871                 /* no magic here, as the prototype will have added an extra
5872                    refgen and we just want what was there before that */
5873                 PUSHs(SvRV(*svp));
5874             else {
5875                 const bool constr = PL_op->op_private & whicharg;
5876                 PUSHs(S_rv2gv(aTHX_
5877                     svp && *svp ? *svp : &PL_sv_undef,
5878                     constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5879                     !constr
5880                 ));
5881             }
5882             break;
5883         case OA_SCALARREF:
5884           if (!numargs) goto try_defsv;
5885           else {
5886             const bool wantscalar =
5887                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5888             if (!svp || !*svp || !SvROK(*svp)
5889                 /* We have to permit globrefs even for the \$ proto, as
5890                    *foo is indistinguishable from ${\*foo}, and the proto-
5891                    type permits the latter. */
5892              || SvTYPE(SvRV(*svp)) > (
5893                      wantscalar       ? SVt_PVLV
5894                    : opnum == OP_LOCK || opnum == OP_UNDEF
5895                                       ? SVt_PVCV
5896                    :                    SVt_PVHV
5897                 )
5898                )
5899                 DIE(aTHX_
5900                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5901                  "Type of arg %d to &CORE::%s must be %s",
5902                   whicharg, PL_op_name[opnum],
5903                   wantscalar
5904                     ? "scalar reference"
5905                     : opnum == OP_LOCK || opnum == OP_UNDEF
5906                        ? "reference to one of [$@%&*]"
5907                        : "reference to one of [$@%*]"
5908                 );
5909             PUSHs(SvRV(*svp));
5910             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
5911              && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5912                 /* Undo @_ localisation, so that sub exit does not undo
5913                    part of our undeffing. */
5914                 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5915                 POP_SAVEARRAY();
5916                 cx->cx_type &= ~ CXp_HASARGS;
5917                 assert(!AvREAL(cx->blk_sub.argarray));
5918             }
5919           }
5920           break;
5921         default:
5922             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5923         }
5924         oa = oa >> 4;
5925     }
5926
5927     RETURN;
5928 }
5929
5930 PP(pp_runcv)
5931 {
5932     dSP;
5933     CV *cv;
5934     if (PL_op->op_private & OPpOFFBYONE) {
5935         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
5936     }
5937     else cv = find_runcv(NULL);
5938     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5939     RETURN;
5940 }
5941
5942
5943 /*
5944  * Local variables:
5945  * c-indentation-style: bsd
5946  * c-basic-offset: 4
5947  * indent-tabs-mode: nil
5948  * End:
5949  *
5950  * ex: set ts=8 sts=4 sw=4 et:
5951  */