pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 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 to discover,
  13  * and no knowing what you'll find around a corner.  And Elves, sir!" --Samwise
  14  */
  15
  16 /* This file contains general pp ("push/pop") functions that execute the
  17  * opcodes that make up a perl program. A typical pp function expects to
  18  * find its arguments on the stack, and usually pushes its results onto
  19  * the stack, hence the 'pp' terminology. Each OP structure contains
  20  * a pointer to the relevant pp_foo() function.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_PP_C
  25 #include "perl.h"
  26 #include "keywords.h"
  27
  28 #include "reentr.h"
  29
  30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  31    it, since pid_t is an integral type.
  32    --AD  2/20/1998
  33 */
  34 #ifdef NEED_GETPID_PROTO
  35 extern Pid_t getpid (void);
  36 #endif
  37
  38 /*
  39  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
  40  * This switches them over to IEEE.
  41  */
  42 #if defined(LIBM_LIB_VERSION)
  43     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
  44 #endif
  45
  46 /* variations on pp_null */
  47
  48 PP(pp_stub)
  49 {
  50     dVAR;
  51     dSP;
  52     if (GIMME_V == G_SCALAR)
  53         XPUSHs(&PL_sv_undef);
  54     RETURN;
  55 }
  56
  57 /* Pushy stuff. */
  58
  59 PP(pp_padav)
  60 {
  61     dVAR; dSP; dTARGET;
  62     I32 gimme;
  63     if (PL_op->op_private & OPpLVAL_INTRO)
  64         if (!(PL_op->op_private & OPpPAD_STATE))
  65             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  66     EXTEND(SP, 1);
  67     if (PL_op->op_flags & OPf_REF) {
  68         PUSHs(TARG);
  69         RETURN;
  70     } else if (LVRET) {
  71         if (GIMME == G_SCALAR)
  72             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  73         PUSHs(TARG);
  74         RETURN;
  75     }
  76     gimme = GIMME_V;
  77     if (gimme == G_ARRAY) {
  78         const I32 maxarg = AvFILL((AV*)TARG) + 1;
  79         EXTEND(SP, maxarg);
  80         if (SvMAGICAL(TARG)) {
  81             U32 i;
  82             for (i=0; i < (U32)maxarg; i++) {
  83                 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
  84                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  85             }
  86         }
  87         else {
  88             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
  89         }
  90         SP += maxarg;
  91     }
  92     else if (gimme == G_SCALAR) {
  93         SV* const sv = sv_newmortal();
  94         const I32 maxarg = AvFILL((AV*)TARG) + 1;
  95         sv_setiv(sv, maxarg);
  96         PUSHs(sv);
  97     }
  98     RETURN;
  99 }
 100
 101 PP(pp_padhv)
 102 {
 103     dVAR; dSP; dTARGET;
 104     I32 gimme;
 105
 106     XPUSHs(TARG);
 107     if (PL_op->op_private & OPpLVAL_INTRO)
 108         if (!(PL_op->op_private & OPpPAD_STATE))
 109             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 110     if (PL_op->op_flags & OPf_REF)
 111         RETURN;
 112     else if (LVRET) {
 113         if (GIMME == G_SCALAR)
 114             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 115         RETURN;
 116     }
 117     gimme = GIMME_V;
 118     if (gimme == G_ARRAY) {
 119         RETURNOP(do_kv());
 120     }
 121     else if (gimme == G_SCALAR) {
 122         SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
 123         SETs(sv);
 124     }
 125     RETURN;
 126 }
 127
 128 /* Translations. */
 129
 130 PP(pp_rv2gv)
 131 {
 132     dVAR; dSP; dTOPss;
 133
 134     if (SvROK(sv)) {
 135       wasref:
 136         tryAMAGICunDEREF(to_gv);
 137
 138         sv = SvRV(sv);
 139         if (SvTYPE(sv) == SVt_PVIO) {
 140             GV * const gv = (GV*) sv_newmortal();
 141             gv_init(gv, 0, "", 0, 0);
 142             GvIOp(gv) = (IO *)sv;
 143             SvREFCNT_inc_void_NN(sv);
 144             sv = (SV*) gv;
 145         }
 146         else if (SvTYPE(sv) != SVt_PVGV)
 147             DIE(aTHX_ "Not a GLOB reference");
 148     }
 149     else {
 150         if (SvTYPE(sv) != SVt_PVGV) {
 151             if (SvGMAGICAL(sv)) {
 152                 mg_get(sv);
 153                 if (SvROK(sv))
 154                     goto wasref;
 155             }
 156             if (!SvOK(sv) && sv != &PL_sv_undef) {
 157                 /* If this is a 'my' scalar and flag is set then vivify
 158                  * NI-S 1999/05/07
 159                  */
 160                 if (SvREADONLY(sv))
 161                     Perl_croak(aTHX_ PL_no_modify);
 162                 if (PL_op->op_private & OPpDEREF) {
 163                     GV *gv;
 164                     if (cUNOP->op_targ) {
 165                         STRLEN len;
 166                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 167                         const char * const name = SvPV(namesv, len);
 168                         gv = (GV*)newSV(0);
 169                         gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
 170                     }
 171                     else {
 172                         const char * const name = CopSTASHPV(PL_curcop);
 173                         gv = newGVgen(name);
 174                     }
 175                     if (SvTYPE(sv) < SVt_RV)
 176                         sv_upgrade(sv, SVt_RV);
 177                     else if (SvPVX_const(sv)) {
 178                         SvPV_free(sv);
 179                         SvLEN_set(sv, 0);
 180                         SvCUR_set(sv, 0);
 181                     }
 182                     SvRV_set(sv, (SV*)gv);
 183                     SvROK_on(sv);
 184                     SvSETMAGIC(sv);
 185                     goto wasref;
 186                 }
 187                 if (PL_op->op_flags & OPf_REF ||
 188                     PL_op->op_private & HINT_STRICT_REFS)
 189                     DIE(aTHX_ PL_no_usym, "a symbol");
 190                 if (ckWARN(WARN_UNINITIALIZED))
 191                     report_uninit(sv);
 192                 RETSETUNDEF;
 193             }
 194             if ((PL_op->op_flags & OPf_SPECIAL) &&
 195                 !(PL_op->op_flags & OPf_MOD))
 196             {
 197                 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
 198                 if (!temp
 199                     && (!is_gv_magical_sv(sv,0)
 200                         || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
 201                     RETSETUNDEF;
 202                 }
 203                 sv = temp;
 204             }
 205             else {
 206                 if (PL_op->op_private & HINT_STRICT_REFS)
 207                     DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
 208                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 209                     == OPpDONT_INIT_GV) {
 210                     /* We are the target of a coderef assignment.  Return
 211                        the scalar unchanged, and let pp_sasssign deal with
 212                        things.  */
 213                     RETURN;
 214                 }
 215                 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
 216             }
 217         }
 218     }
 219     if (PL_op->op_private & OPpLVAL_INTRO)
 220         save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
 221     SETs(sv);
 222     RETURN;
 223 }
 224
 225 PP(pp_rv2sv)
 226 {
 227     dVAR; dSP; dTOPss;
 228     GV *gv = NULL;
 229
 230     if (SvROK(sv)) {
 231       wasref:
 232         tryAMAGICunDEREF(to_sv);
 233
 234         sv = SvRV(sv);
 235         switch (SvTYPE(sv)) {
 236         case SVt_PVAV:
 237         case SVt_PVHV:
 238         case SVt_PVCV:
 239         case SVt_PVFM:
 240         case SVt_PVIO:
 241             DIE(aTHX_ "Not a SCALAR reference");
 242         }
 243     }
 244     else {
 245         gv = (GV*)sv;
 246
 247         if (SvTYPE(gv) != SVt_PVGV) {
 248             if (SvGMAGICAL(sv)) {
 249                 mg_get(sv);
 250                 if (SvROK(sv))
 251                     goto wasref;
 252             }
 253             if (PL_op->op_private & HINT_STRICT_REFS) {
 254                 if (SvOK(sv))
 255                     DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
 256                 else
 257                     DIE(aTHX_ PL_no_usym, "a SCALAR");
 258             }
 259             if (!SvOK(sv)) {
 260                 if (PL_op->op_flags & OPf_REF)
 261                     DIE(aTHX_ PL_no_usym, "a SCALAR");
 262                 if (ckWARN(WARN_UNINITIALIZED))
 263                     report_uninit(sv);
 264                 RETSETUNDEF;
 265             }
 266             if ((PL_op->op_flags & OPf_SPECIAL) &&
 267                 !(PL_op->op_flags & OPf_MOD))
 268             {
 269                 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
 270                 if (!gv
 271                     && (!is_gv_magical_sv(sv, 0)
 272                         || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
 273                 {
 274                     RETSETUNDEF;
 275                 }
 276             }
 277             else {
 278                 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
 279             }
 280         }
 281         sv = GvSVn(gv);
 282     }
 283     if (PL_op->op_flags & OPf_MOD) {
 284         if (PL_op->op_private & OPpLVAL_INTRO) {
 285             if (cUNOP->op_first->op_type == OP_NULL)
 286                 sv = save_scalar((GV*)TOPs);
 287             else if (gv)
 288                 sv = save_scalar(gv);
 289             else
 290                 Perl_croak(aTHX_ PL_no_localize_ref);
 291         }
 292         else if (PL_op->op_private & OPpDEREF)
 293             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 294     }
 295     SETs(sv);
 296     RETURN;
 297 }
 298
 299 PP(pp_av2arylen)
 300 {
 301     dVAR; dSP;
 302     AV * const av = (AV*)TOPs;
 303     SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
 304     if (!*sv) {
 305         *sv = newSV(0);
 306         sv_upgrade(*sv, SVt_PVMG);
 307         sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
 308     }
 309     SETs(*sv);
 310     RETURN;
 311 }
 312
 313 PP(pp_pos)
 314 {
 315     dVAR; dSP; dTARGET; dPOPss;
 316
 317     if (PL_op->op_flags & OPf_MOD || LVRET) {
 318         if (SvTYPE(TARG) < SVt_PVLV) {
 319             sv_upgrade(TARG, SVt_PVLV);
 320             sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
 321         }
 322
 323         LvTYPE(TARG) = '.';
 324         if (LvTARG(TARG) != sv) {
 325             if (LvTARG(TARG))
 326                 SvREFCNT_dec(LvTARG(TARG));
 327             LvTARG(TARG) = SvREFCNT_inc_simple(sv);
 328         }
 329         PUSHs(TARG);    /* no SvSETMAGIC */
 330         RETURN;
 331     }
 332     else {
 333         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 334             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
 335             if (mg && mg->mg_len >= 0) {
 336                 I32 i = mg->mg_len;
 337                 if (DO_UTF8(sv))
 338                     sv_pos_b2u(sv, &i);
 339                 PUSHi(i + CopARYBASE_get(PL_curcop));
 340                 RETURN;
 341             }
 342         }
 343         RETPUSHUNDEF;
 344     }
 345 }
 346
 347 PP(pp_rv2cv)
 348 {
 349     dVAR; dSP;
 350     GV *gv;
 351     HV *stash_unused;
 352     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 353         ? 0
 354         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
 355             ? GV_ADD|GV_NOEXPAND
 356             : GV_ADD;
 357     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 358     /* (But not in defined().) */
 359
 360     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 361     if (cv) {
 362         if (CvCLONE(cv))
 363             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 364         if ((PL_op->op_private & OPpLVAL_INTRO)) {
 365             if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
 366                 cv = GvCV(gv);
 367             if (!CvLVALUE(cv))
 368                 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
 369         }
 370     }
 371     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 372         cv = (CV*)gv;
 373     }
 374     else
 375         cv = (CV*)&PL_sv_undef;
 376     SETs((SV*)cv);
 377     RETURN;
 378 }
 379
 380 PP(pp_prototype)
 381 {
 382     dVAR; dSP;
 383     CV *cv;
 384     HV *stash;
 385     GV *gv;
 386     SV *ret = &PL_sv_undef;
 387
 388     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 389         const char * const s = SvPVX_const(TOPs);
 390         if (strnEQ(s, "CORE::", 6)) {
 391             const int code = keyword(s + 6, SvCUR(TOPs) - 6);
 392             if (code < 0) {     /* Overridable. */
 393 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 394                 int i = 0, n = 0, seen_question = 0;
 395                 I32 oa;
 396                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 397
 398                 if (code == -KEY_chop || code == -KEY_chomp
 399                         || code == -KEY_exec || code == -KEY_system)
 400                     goto set;
 401                 while (i < MAXO) {      /* The slow way. */
 402                     if (strEQ(s + 6, PL_op_name[i])
 403                         || strEQ(s + 6, PL_op_desc[i]))
 404                     {
 405                         goto found;
 406                     }
 407                     i++;
 408                 }
 409                 goto nonesuch;          /* Should not happen... */
 410               found:
 411                 oa = PL_opargs[i] >> OASHIFT;
 412                 while (oa) {
 413                     if (oa & OA_OPTIONAL && !seen_question) {
 414                         seen_question = 1;
 415                         str[n++] = ';';
 416                     }
 417                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 418                         && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
 419                         /* But globs are already references (kinda) */
 420                         && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
 421                     ) {
 422                         str[n++] = '\\';
 423                     }
 424                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 425                     oa = oa >> 4;
 426                 }
 427                 str[n++] = '\0';
 428                 ret = sv_2mortal(newSVpvn(str, n - 1));
 429             }
 430             else if (code)              /* Non-Overridable */
 431                 goto set;
 432             else {                      /* None such */
 433               nonesuch:
 434                 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
 435             }
 436         }
 437     }
 438     cv = sv_2cv(TOPs, &stash, &gv, 0);
 439     if (cv && SvPOK(cv))
 440         ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
 441   set:
 442     SETs(ret);
 443     RETURN;
 444 }
 445
 446 PP(pp_anoncode)
 447 {
 448     dVAR; dSP;
 449     CV* cv = (CV*)PAD_SV(PL_op->op_targ);
 450     if (CvCLONE(cv))
 451         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 452     EXTEND(SP,1);
 453     PUSHs((SV*)cv);
 454     RETURN;
 455 }
 456
 457 PP(pp_srefgen)
 458 {
 459     dVAR; dSP;
 460     *SP = refto(*SP);
 461     RETURN;
 462 }
 463
 464 PP(pp_refgen)
 465 {
 466     dVAR; dSP; dMARK;
 467     if (GIMME != G_ARRAY) {
 468         if (++MARK <= SP)
 469             *MARK = *SP;
 470         else
 471             *MARK = &PL_sv_undef;
 472         *MARK = refto(*MARK);
 473         SP = MARK;
 474         RETURN;
 475     }
 476     EXTEND_MORTAL(SP - MARK);
 477     while (++MARK <= SP)
 478         *MARK = refto(*MARK);
 479     RETURN;
 480 }
 481
 482 STATIC SV*
 483 S_refto(pTHX_ SV *sv)
 484 {
 485     dVAR;
 486     SV* rv;
 487
 488     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 489         if (LvTARGLEN(sv))
 490             vivify_defelem(sv);
 491         if (!(sv = LvTARG(sv)))
 492             sv = &PL_sv_undef;
 493         else
 494             SvREFCNT_inc_void_NN(sv);
 495     }
 496     else if (SvTYPE(sv) == SVt_PVAV) {
 497         if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
 498             av_reify((AV*)sv);
 499         SvTEMP_off(sv);
 500         SvREFCNT_inc_void_NN(sv);
 501     }
 502     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 503         sv = newSVsv(sv);
 504     else {
 505         SvTEMP_off(sv);
 506         SvREFCNT_inc_void_NN(sv);
 507     }
 508     rv = sv_newmortal();
 509     sv_upgrade(rv, SVt_RV);
 510     SvRV_set(rv, sv);
 511     SvROK_on(rv);
 512     return rv;
 513 }
 514
 515 PP(pp_ref)
 516 {
 517     dVAR; dSP; dTARGET;
 518     const char *pv;
 519     SV * const sv = POPs;
 520
 521     if (sv)
 522         SvGETMAGIC(sv);
 523
 524     if (!sv || !SvROK(sv))
 525         RETPUSHNO;
 526
 527     pv = sv_reftype(SvRV(sv),TRUE);
 528     PUSHp(pv, strlen(pv));
 529     RETURN;
 530 }
 531
 532 PP(pp_bless)
 533 {
 534     dVAR; dSP;
 535     HV *stash;
 536
 537     if (MAXARG == 1)
 538         stash = CopSTASH(PL_curcop);
 539     else {
 540         SV * const ssv = POPs;
 541         STRLEN len;
 542         const char *ptr;
 543
 544         if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
 545             Perl_croak(aTHX_ "Attempt to bless into a reference");
 546         ptr = SvPV_const(ssv,len);
 547         if (len == 0 && ckWARN(WARN_MISC))
 548             Perl_warner(aTHX_ packWARN(WARN_MISC),
 549                    "Explicit blessing to '' (assuming package main)");
 550         stash = gv_stashpvn(ptr, len, TRUE);
 551     }
 552
 553     (void)sv_bless(TOPs, stash);
 554     RETURN;
 555 }
 556
 557 PP(pp_gelem)
 558 {
 559     dVAR; dSP;
 560
 561     SV *sv = POPs;
 562     const char * const elem = SvPV_nolen_const(sv);
 563     GV * const gv = (GV*)POPs;
 564     SV * tmpRef = NULL;
 565
 566     sv = NULL;
 567     if (elem) {
 568         /* elem will always be NUL terminated.  */
 569         const char * const second_letter = elem + 1;
 570         switch (*elem) {
 571         case 'A':
 572             if (strEQ(second_letter, "RRAY"))
 573                 tmpRef = (SV*)GvAV(gv);
 574             break;
 575         case 'C':
 576             if (strEQ(second_letter, "ODE"))
 577                 tmpRef = (SV*)GvCVu(gv);
 578             break;
 579         case 'F':
 580             if (strEQ(second_letter, "ILEHANDLE")) {
 581                 /* finally deprecated in 5.8.0 */
 582                 deprecate("*glob{FILEHANDLE}");
 583                 tmpRef = (SV*)GvIOp(gv);
 584             }
 585             else
 586                 if (strEQ(second_letter, "ORMAT"))
 587                     tmpRef = (SV*)GvFORM(gv);
 588             break;
 589         case 'G':
 590             if (strEQ(second_letter, "LOB"))
 591                 tmpRef = (SV*)gv;
 592             break;
 593         case 'H':
 594             if (strEQ(second_letter, "ASH"))
 595                 tmpRef = (SV*)GvHV(gv);
 596             break;
 597         case 'I':
 598             if (*second_letter == 'O' && !elem[2])
 599                 tmpRef = (SV*)GvIOp(gv);
 600             break;
 601         case 'N':
 602             if (strEQ(second_letter, "AME"))
 603                 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
 604             break;
 605         case 'P':
 606             if (strEQ(second_letter, "ACKAGE")) {
 607                 const HV * const stash = GvSTASH(gv);
 608                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 609                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 610             }
 611             break;
 612         case 'S':
 613             if (strEQ(second_letter, "CALAR"))
 614                 tmpRef = GvSVn(gv);
 615             break;
 616         }
 617     }
 618     if (tmpRef)
 619         sv = newRV(tmpRef);
 620     if (sv)
 621         sv_2mortal(sv);
 622     else
 623         sv = &PL_sv_undef;
 624     XPUSHs(sv);
 625     RETURN;
 626 }
 627
 628 /* Pattern matching */
 629
 630 PP(pp_study)
 631 {
 632     dVAR; dSP; dPOPss;
 633     register unsigned char *s;
 634     register I32 pos;
 635     register I32 ch;
 636     register I32 *sfirst;
 637     register I32 *snext;
 638     STRLEN len;
 639
 640     if (sv == PL_lastscream) {
 641         if (SvSCREAM(sv))
 642             RETPUSHYES;
 643     }
 644     s = (unsigned char*)(SvPV(sv, len));
 645     pos = len;
 646     if (pos <= 0 || !SvPOK(sv)) {
 647         /* No point in studying a zero length string, and not safe to study
 648            anything that doesn't appear to be a simple scalar (and hence might
 649            change between now and when the regexp engine runs without our set
 650            magic ever running) such as a reference to an object with overloaded
 651            stringification.  */
 652         RETPUSHNO;
 653     }
 654
 655     if (PL_lastscream) {
 656         SvSCREAM_off(PL_lastscream);
 657         SvREFCNT_dec(PL_lastscream);
 658     }
 659     PL_lastscream = SvREFCNT_inc_simple(sv);
 660
 661     s = (unsigned char*)(SvPV(sv, len));
 662     pos = len;
 663     if (pos <= 0)
 664         RETPUSHNO;
 665     if (pos > PL_maxscream) {
 666         if (PL_maxscream < 0) {
 667             PL_maxscream = pos + 80;
 668             Newx(PL_screamfirst, 256, I32);
 669             Newx(PL_screamnext, PL_maxscream, I32);
 670         }
 671         else {
 672             PL_maxscream = pos + pos / 4;
 673             Renew(PL_screamnext, PL_maxscream, I32);
 674         }
 675     }
 676
 677     sfirst = PL_screamfirst;
 678     snext = PL_screamnext;
 679
 680     if (!sfirst || !snext)
 681         DIE(aTHX_ "do_study: out of memory");
 682
 683     for (ch = 256; ch; --ch)
 684         *sfirst++ = -1;
 685     sfirst -= 256;
 686
 687     while (--pos >= 0) {
 688         register const I32 ch = s[pos];
 689         if (sfirst[ch] >= 0)
 690             snext[pos] = sfirst[ch] - pos;
 691         else
 692             snext[pos] = -pos;
 693         sfirst[ch] = pos;
 694     }
 695
 696     SvSCREAM_on(sv);
 697     /* piggyback on m//g magic */
 698     sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
 699     RETPUSHYES;
 700 }
 701
 702 PP(pp_trans)
 703 {
 704     dVAR; dSP; dTARG;
 705     SV *sv;
 706
 707     if (PL_op->op_flags & OPf_STACKED)
 708         sv = POPs;
 709     else if (PL_op->op_private & OPpTARGET_MY)
 710         sv = GETTARGET;
 711     else {
 712         sv = DEFSV;
 713         EXTEND(SP,1);
 714     }
 715     TARG = sv_newmortal();
 716     PUSHi(do_trans(sv));
 717     RETURN;
 718 }
 719
 720 /* Lvalue operators. */
 721
 722 PP(pp_schop)
 723 {
 724     dVAR; dSP; dTARGET;
 725     do_chop(TARG, TOPs);
 726     SETTARG;
 727     RETURN;
 728 }
 729
 730 PP(pp_chop)
 731 {
 732     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
 733     while (MARK < SP)
 734         do_chop(TARG, *++MARK);
 735     SP = ORIGMARK;
 736     XPUSHTARG;
 737     RETURN;
 738 }
 739
 740 PP(pp_schomp)
 741 {
 742     dVAR; dSP; dTARGET;
 743     SETi(do_chomp(TOPs));
 744     RETURN;
 745 }
 746
 747 PP(pp_chomp)
 748 {
 749     dVAR; dSP; dMARK; dTARGET;
 750     register I32 count = 0;
 751
 752     while (SP > MARK)
 753         count += do_chomp(POPs);
 754     XPUSHi(count);
 755     RETURN;
 756 }
 757
 758 PP(pp_undef)
 759 {
 760     dVAR; dSP;
 761     SV *sv;
 762
 763     if (!PL_op->op_private) {
 764         EXTEND(SP, 1);
 765         RETPUSHUNDEF;
 766     }
 767
 768     sv = POPs;
 769     if (!sv)
 770         RETPUSHUNDEF;
 771
 772     SV_CHECK_THINKFIRST_COW_DROP(sv);
 773
 774     switch (SvTYPE(sv)) {
 775     case SVt_NULL:
 776         break;
 777     case SVt_PVAV:
 778         av_undef((AV*)sv);
 779         break;
 780     case SVt_PVHV:
 781         hv_undef((HV*)sv);
 782         break;
 783     case SVt_PVCV:
 784         if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
 785             Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
 786                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
 787         /* FALLTHROUGH */
 788     case SVt_PVFM:
 789         {
 790             /* let user-undef'd sub keep its identity */
 791             GV* const gv = CvGV((CV*)sv);
 792             cv_undef((CV*)sv);
 793             CvGV((CV*)sv) = gv;
 794         }
 795         break;
 796     case SVt_PVGV:
 797         if (SvFAKE(sv))
 798             SvSetMagicSV(sv, &PL_sv_undef);
 799         else {
 800             GP *gp;
 801             gp_free((GV*)sv);
 802             Newxz(gp, 1, GP);
 803             GvGP(sv) = gp_ref(gp);
 804             GvSV(sv) = newSV(0);
 805             GvLINE(sv) = CopLINE(PL_curcop);
 806             GvEGV(sv) = (GV*)sv;
 807             GvMULTI_on(sv);
 808         }
 809         break;
 810     default:
 811         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 812             SvPV_free(sv);
 813             SvPV_set(sv, NULL);
 814             SvLEN_set(sv, 0);
 815         }
 816         SvOK_off(sv);
 817         SvSETMAGIC(sv);
 818     }
 819
 820     RETPUSHUNDEF;
 821 }
 822
 823 PP(pp_predec)
 824 {
 825     dVAR; dSP;
 826     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 827         DIE(aTHX_ PL_no_modify);
 828     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 829         && SvIVX(TOPs) != IV_MIN)
 830     {
 831         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 832         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 833     }
 834     else
 835         sv_dec(TOPs);
 836     SvSETMAGIC(TOPs);
 837     return NORMAL;
 838 }
 839
 840 PP(pp_postinc)
 841 {
 842     dVAR; dSP; dTARGET;
 843     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 844         DIE(aTHX_ PL_no_modify);
 845     sv_setsv(TARG, TOPs);
 846     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 847         && SvIVX(TOPs) != IV_MAX)
 848     {
 849         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 850         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 851     }
 852     else
 853         sv_inc(TOPs);
 854     SvSETMAGIC(TOPs);
 855     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
 856     if (!SvOK(TARG))
 857         sv_setiv(TARG, 0);
 858     SETs(TARG);
 859     return NORMAL;
 860 }
 861
 862 PP(pp_postdec)
 863 {
 864     dVAR; dSP; dTARGET;
 865     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 866         DIE(aTHX_ PL_no_modify);
 867     sv_setsv(TARG, TOPs);
 868     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 869         && SvIVX(TOPs) != IV_MIN)
 870     {
 871         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 872         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 873     }
 874     else
 875         sv_dec(TOPs);
 876     SvSETMAGIC(TOPs);
 877     SETs(TARG);
 878     return NORMAL;
 879 }
 880
 881 /* Ordinary operators. */
 882
 883 PP(pp_pow)
 884 {
 885     dVAR; dSP; dATARGET;
 886 #ifdef PERL_PRESERVE_IVUV
 887     bool is_int = 0;
 888 #endif
 889     tryAMAGICbin(pow,opASSIGN);
 890 #ifdef PERL_PRESERVE_IVUV
 891     /* For integer to integer power, we do the calculation by hand wherever
 892        we're sure it is safe; otherwise we call pow() and try to convert to
 893        integer afterwards. */
 894     {
 895         SvIV_please(TOPs);
 896         if (SvIOK(TOPs)) {
 897             SvIV_please(TOPm1s);
 898             if (SvIOK(TOPm1s)) {
 899                 UV power;
 900                 bool baseuok;
 901                 UV baseuv;
 902
 903                 if (SvUOK(TOPs)) {
 904                     power = SvUVX(TOPs);
 905                 } else {
 906                     const IV iv = SvIVX(TOPs);
 907                     if (iv >= 0) {
 908                         power = iv;
 909                     } else {
 910                         goto float_it; /* Can't do negative powers this way.  */
 911                     }
 912                 }
 913
 914                 baseuok = SvUOK(TOPm1s);
 915                 if (baseuok) {
 916                     baseuv = SvUVX(TOPm1s);
 917                 } else {
 918                     const IV iv = SvIVX(TOPm1s);
 919                     if (iv >= 0) {
 920                         baseuv = iv;
 921                         baseuok = TRUE; /* effectively it's a UV now */
 922                     } else {
 923                         baseuv = -iv; /* abs, baseuok == false records sign */
 924                     }
 925                 }
 926                 /* now we have integer ** positive integer. */
 927                 is_int = 1;
 928
 929                 /* foo & (foo - 1) is zero only for a power of 2.  */
 930                 if (!(baseuv & (baseuv - 1))) {
 931                     /* We are raising power-of-2 to a positive integer.
 932                        The logic here will work for any base (even non-integer
 933                        bases) but it can be less accurate than
 934                        pow (base,power) or exp (power * log (base)) when the
 935                        intermediate values start to spill out of the mantissa.
 936                        With powers of 2 we know this can't happen.
 937                        And powers of 2 are the favourite thing for perl
 938                        programmers to notice ** not doing what they mean. */
 939                     NV result = 1.0;
 940                     NV base = baseuok ? baseuv : -(NV)baseuv;
 941
 942                     if (power & 1) {
 943                         result *= base;
 944                     }
 945                     while (power >>= 1) {
 946                         base *= base;
 947                         if (power & 1) {
 948                             result *= base;
 949                         }
 950                     }
 951                     SP--;
 952                     SETn( result );
 953                     SvIV_please(TOPs);
 954                     RETURN;
 955                 } else {
 956                     register unsigned int highbit = 8 * sizeof(UV);
 957                     register unsigned int diff = 8 * sizeof(UV);
 958                     while (diff >>= 1) {
 959                         highbit -= diff;
 960                         if (baseuv >> highbit) {
 961                             highbit += diff;
 962                         }
 963                     }
 964                     /* we now have baseuv < 2 ** highbit */
 965                     if (power * highbit <= 8 * sizeof(UV)) {
 966                         /* result will definitely fit in UV, so use UV math
 967                            on same algorithm as above */
 968                         register UV result = 1;
 969                         register UV base = baseuv;
 970                         const bool odd_power = (bool)(power & 1);
 971                         if (odd_power) {
 972                             result *= base;
 973                         }
 974                         while (power >>= 1) {
 975                             base *= base;
 976                             if (power & 1) {
 977                                 result *= base;
 978                             }
 979                         }
 980                         SP--;
 981                         if (baseuok || !odd_power)
 982                             /* answer is positive */
 983                             SETu( result );
 984                         else if (result <= (UV)IV_MAX)
 985                             /* answer negative, fits in IV */
 986                             SETi( -(IV)result );
 987                         else if (result == (UV)IV_MIN)
 988                             /* 2's complement assumption: special case IV_MIN */
 989                             SETi( IV_MIN );
 990                         else
 991                             /* answer negative, doesn't fit */
 992                             SETn( -(NV)result );
 993                         RETURN;
 994                     }
 995                 }
 996             }
 997         }
 998     }
 999   float_it:
1000 #endif
1001     {
1002         dPOPTOPnnrl;
1003
1004 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1005     /*
1006     We are building perl with long double support and are on an AIX OS
1007     afflicted with a powl() function that wrongly returns NaNQ for any
1008     negative base.  This was reported to IBM as PMR #23047-379 on
1009     03/06/2006.  The problem exists in at least the following versions
1010     of AIX and the libm fileset, and no doubt others as well:
1011
1012         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1013         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1014         AIX 5.2.0           bos.adt.libm 5.2.0.85
1015
1016     So, until IBM fixes powl(), we provide the following workaround to
1017     handle the problem ourselves.  Our logic is as follows: for
1018     negative bases (left), we use fmod(right, 2) to check if the
1019     exponent is an odd or even integer:
1020
1021         - if odd,  powl(left, right) == -powl(-left, right)
1022         - if even, powl(left, right) ==  powl(-left, right)
1023
1024     If the exponent is not an integer, the result is rightly NaNQ, so
1025     we just return that (as NV_NAN).
1026     */
1027
1028         if (left < 0.0) {
1029             NV mod2 = Perl_fmod( right, 2.0 );
1030             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1031                 SETn( -Perl_pow( -left, right) );
1032             } else if (mod2 == 0.0) {           /* even integer */
1033                 SETn( Perl_pow( -left, right) );
1034             } else {                            /* fractional power */
1035                 SETn( NV_NAN );
1036             }
1037         } else {
1038             SETn( Perl_pow( left, right) );
1039         }
1040 #else
1041         SETn( Perl_pow( left, right) );
1042 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1043
1044 #ifdef PERL_PRESERVE_IVUV
1045         if (is_int)
1046             SvIV_please(TOPs);
1047 #endif
1048         RETURN;
1049     }
1050 }
1051
1052 PP(pp_multiply)
1053 {
1054     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1055 #ifdef PERL_PRESERVE_IVUV
1056     SvIV_please(TOPs);
1057     if (SvIOK(TOPs)) {
1058         /* Unless the left argument is integer in range we are going to have to
1059            use NV maths. Hence only attempt to coerce the right argument if
1060            we know the left is integer.  */
1061         /* Left operand is defined, so is it IV? */
1062         SvIV_please(TOPm1s);
1063         if (SvIOK(TOPm1s)) {
1064             bool auvok = SvUOK(TOPm1s);
1065             bool buvok = SvUOK(TOPs);
1066             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1067             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1068             UV alow;
1069             UV ahigh;
1070             UV blow;
1071             UV bhigh;
1072
1073             if (auvok) {
1074                 alow = SvUVX(TOPm1s);
1075             } else {
1076                 const IV aiv = SvIVX(TOPm1s);
1077                 if (aiv >= 0) {
1078                     alow = aiv;
1079                     auvok = TRUE; /* effectively it's a UV now */
1080                 } else {
1081                     alow = -aiv; /* abs, auvok == false records sign */
1082                 }
1083             }
1084             if (buvok) {
1085                 blow = SvUVX(TOPs);
1086             } else {
1087                 const IV biv = SvIVX(TOPs);
1088                 if (biv >= 0) {
1089                     blow = biv;
1090                     buvok = TRUE; /* effectively it's a UV now */
1091                 } else {
1092                     blow = -biv; /* abs, buvok == false records sign */
1093                 }
1094             }
1095
1096             /* If this does sign extension on unsigned it's time for plan B  */
1097             ahigh = alow >> (4 * sizeof (UV));
1098             alow &= botmask;
1099             bhigh = blow >> (4 * sizeof (UV));
1100             blow &= botmask;
1101             if (ahigh && bhigh) {
1102                 NOOP;
1103                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1104                    which is overflow. Drop to NVs below.  */
1105             } else if (!ahigh && !bhigh) {
1106                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1107                    so the unsigned multiply cannot overflow.  */
1108                 const UV product = alow * blow;
1109                 if (auvok == buvok) {
1110                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1111                     SP--;
1112                     SETu( product );
1113                     RETURN;
1114                 } else if (product <= (UV)IV_MIN) {
1115                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1116                     /* -ve result, which could overflow an IV  */
1117                     SP--;
1118                     SETi( -(IV)product );
1119                     RETURN;
1120                 } /* else drop to NVs below. */
1121             } else {
1122                 /* One operand is large, 1 small */
1123                 UV product_middle;
1124                 if (bhigh) {
1125                     /* swap the operands */
1126                     ahigh = bhigh;
1127                     bhigh = blow; /* bhigh now the temp var for the swap */
1128                     blow = alow;
1129                     alow = bhigh;
1130                 }
1131                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1132                    multiplies can't overflow. shift can, add can, -ve can.  */
1133                 product_middle = ahigh * blow;
1134                 if (!(product_middle & topmask)) {
1135                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1136                     UV product_low;
1137                     product_middle <<= (4 * sizeof (UV));
1138                     product_low = alow * blow;
1139
1140                     /* as for pp_add, UV + something mustn't get smaller.
1141                        IIRC ANSI mandates this wrapping *behaviour* for
1142                        unsigned whatever the actual representation*/
1143                     product_low += product_middle;
1144                     if (product_low >= product_middle) {
1145                         /* didn't overflow */
1146                         if (auvok == buvok) {
1147                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1148                             SP--;
1149                             SETu( product_low );
1150                             RETURN;
1151                         } else if (product_low <= (UV)IV_MIN) {
1152                             /* 2s complement assumption again  */
1153                             /* -ve result, which could overflow an IV  */
1154                             SP--;
1155                             SETi( -(IV)product_low );
1156                             RETURN;
1157                         } /* else drop to NVs below. */
1158                     }
1159                 } /* product_middle too large */
1160             } /* ahigh && bhigh */
1161         } /* SvIOK(TOPm1s) */
1162     } /* SvIOK(TOPs) */
1163 #endif
1164     {
1165       dPOPTOPnnrl;
1166       SETn( left * right );
1167       RETURN;
1168     }
1169 }
1170
1171 PP(pp_divide)
1172 {
1173     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1174     /* Only try to do UV divide first
1175        if ((SLOPPYDIVIDE is true) or
1176            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1177             to preserve))
1178        The assumption is that it is better to use floating point divide
1179        whenever possible, only doing integer divide first if we can't be sure.
1180        If NV_PRESERVES_UV is true then we know at compile time that no UV
1181        can be too large to preserve, so don't need to compile the code to
1182        test the size of UVs.  */
1183
1184 #ifdef SLOPPYDIVIDE
1185 #  define PERL_TRY_UV_DIVIDE
1186     /* ensure that 20./5. == 4. */
1187 #else
1188 #  ifdef PERL_PRESERVE_IVUV
1189 #    ifndef NV_PRESERVES_UV
1190 #      define PERL_TRY_UV_DIVIDE
1191 #    endif
1192 #  endif
1193 #endif
1194
1195 #ifdef PERL_TRY_UV_DIVIDE
1196     SvIV_please(TOPs);
1197     if (SvIOK(TOPs)) {
1198         SvIV_please(TOPm1s);
1199         if (SvIOK(TOPm1s)) {
1200             bool left_non_neg = SvUOK(TOPm1s);
1201             bool right_non_neg = SvUOK(TOPs);
1202             UV left;
1203             UV right;
1204
1205             if (right_non_neg) {
1206                 right = SvUVX(TOPs);
1207             }
1208             else {
1209                 const IV biv = SvIVX(TOPs);
1210                 if (biv >= 0) {
1211                     right = biv;
1212                     right_non_neg = TRUE; /* effectively it's a UV now */
1213                 }
1214                 else {
1215                     right = -biv;
1216                 }
1217             }
1218             /* historically undef()/0 gives a "Use of uninitialized value"
1219                warning before dieing, hence this test goes here.
1220                If it were immediately before the second SvIV_please, then
1221                DIE() would be invoked before left was even inspected, so
1222                no inpsection would give no warning.  */
1223             if (right == 0)
1224                 DIE(aTHX_ "Illegal division by zero");
1225
1226             if (left_non_neg) {
1227                 left = SvUVX(TOPm1s);
1228             }
1229             else {
1230                 const IV aiv = SvIVX(TOPm1s);
1231                 if (aiv >= 0) {
1232                     left = aiv;
1233                     left_non_neg = TRUE; /* effectively it's a UV now */
1234                 }
1235                 else {
1236                     left = -aiv;
1237                 }
1238             }
1239
1240             if (left >= right
1241 #ifdef SLOPPYDIVIDE
1242                 /* For sloppy divide we always attempt integer division.  */
1243 #else
1244                 /* Otherwise we only attempt it if either or both operands
1245                    would not be preserved by an NV.  If both fit in NVs
1246                    we fall through to the NV divide code below.  However,
1247                    as left >= right to ensure integer result here, we know that
1248                    we can skip the test on the right operand - right big
1249                    enough not to be preserved can't get here unless left is
1250                    also too big.  */
1251
1252                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1253 #endif
1254                 ) {
1255                 /* Integer division can't overflow, but it can be imprecise.  */
1256                 const UV result = left / right;
1257                 if (result * right == left) {
1258                     SP--; /* result is valid */
1259                     if (left_non_neg == right_non_neg) {
1260                         /* signs identical, result is positive.  */
1261                         SETu( result );
1262                         RETURN;
1263                     }
1264                     /* 2s complement assumption */
1265                     if (result <= (UV)IV_MIN)
1266                         SETi( -(IV)result );
1267                     else {
1268                         /* It's exact but too negative for IV. */
1269                         SETn( -(NV)result );
1270                     }
1271                     RETURN;
1272                 } /* tried integer divide but it was not an integer result */
1273             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1274         } /* left wasn't SvIOK */
1275     } /* right wasn't SvIOK */
1276 #endif /* PERL_TRY_UV_DIVIDE */
1277     {
1278         dPOPPOPnnrl;
1279         if (right == 0.0)
1280             DIE(aTHX_ "Illegal division by zero");
1281         PUSHn( left / right );
1282         RETURN;
1283     }
1284 }
1285
1286 PP(pp_modulo)
1287 {
1288     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1289     {
1290         UV left  = 0;
1291         UV right = 0;
1292         bool left_neg = FALSE;
1293         bool right_neg = FALSE;
1294         bool use_double = FALSE;
1295         bool dright_valid = FALSE;
1296         NV dright = 0.0;
1297         NV dleft  = 0.0;
1298
1299         SvIV_please(TOPs);
1300         if (SvIOK(TOPs)) {
1301             right_neg = !SvUOK(TOPs);
1302             if (!right_neg) {
1303                 right = SvUVX(POPs);
1304             } else {
1305                 const IV biv = SvIVX(POPs);
1306                 if (biv >= 0) {
1307                     right = biv;
1308                     right_neg = FALSE; /* effectively it's a UV now */
1309                 } else {
1310                     right = -biv;
1311                 }
1312             }
1313         }
1314         else {
1315             dright = POPn;
1316             right_neg = dright < 0;
1317             if (right_neg)
1318                 dright = -dright;
1319             if (dright < UV_MAX_P1) {
1320                 right = U_V(dright);
1321                 dright_valid = TRUE; /* In case we need to use double below.  */
1322             } else {
1323                 use_double = TRUE;
1324             }
1325         }
1326
1327         /* At this point use_double is only true if right is out of range for
1328            a UV.  In range NV has been rounded down to nearest UV and
1329            use_double false.  */
1330         SvIV_please(TOPs);
1331         if (!use_double && SvIOK(TOPs)) {
1332             if (SvIOK(TOPs)) {
1333                 left_neg = !SvUOK(TOPs);
1334                 if (!left_neg) {
1335                     left = SvUVX(POPs);
1336                 } else {
1337                     const IV aiv = SvIVX(POPs);
1338                     if (aiv >= 0) {
1339                         left = aiv;
1340                         left_neg = FALSE; /* effectively it's a UV now */
1341                     } else {
1342                         left = -aiv;
1343                     }
1344                 }
1345             }
1346         }
1347         else {
1348             dleft = POPn;
1349             left_neg = dleft < 0;
1350             if (left_neg)
1351                 dleft = -dleft;
1352
1353             /* This should be exactly the 5.6 behaviour - if left and right are
1354                both in range for UV then use U_V() rather than floor.  */
1355             if (!use_double) {
1356                 if (dleft < UV_MAX_P1) {
1357                     /* right was in range, so is dleft, so use UVs not double.
1358                      */
1359                     left = U_V(dleft);
1360                 }
1361                 /* left is out of range for UV, right was in range, so promote
1362                    right (back) to double.  */
1363                 else {
1364                     /* The +0.5 is used in 5.6 even though it is not strictly
1365                        consistent with the implicit +0 floor in the U_V()
1366                        inside the #if 1. */
1367                     dleft = Perl_floor(dleft + 0.5);
1368                     use_double = TRUE;
1369                     if (dright_valid)
1370                         dright = Perl_floor(dright + 0.5);
1371                     else
1372                         dright = right;
1373                 }
1374             }
1375         }
1376         if (use_double) {
1377             NV dans;
1378
1379             if (!dright)
1380                 DIE(aTHX_ "Illegal modulus zero");
1381
1382             dans = Perl_fmod(dleft, dright);
1383             if ((left_neg != right_neg) && dans)
1384                 dans = dright - dans;
1385             if (right_neg)
1386                 dans = -dans;
1387             sv_setnv(TARG, dans);
1388         }
1389         else {
1390             UV ans;
1391
1392             if (!right)
1393                 DIE(aTHX_ "Illegal modulus zero");
1394
1395             ans = left % right;
1396             if ((left_neg != right_neg) && ans)
1397                 ans = right - ans;
1398             if (right_neg) {
1399                 /* XXX may warn: unary minus operator applied to unsigned type */
1400                 /* could change -foo to be (~foo)+1 instead     */
1401                 if (ans <= ~((UV)IV_MAX)+1)
1402                     sv_setiv(TARG, ~ans+1);
1403                 else
1404                     sv_setnv(TARG, -(NV)ans);
1405             }
1406             else
1407                 sv_setuv(TARG, ans);
1408         }
1409         PUSHTARG;
1410         RETURN;
1411     }
1412 }
1413
1414 PP(pp_repeat)
1415 {
1416   dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1417   {
1418     register IV count;
1419     dPOPss;
1420     SvGETMAGIC(sv);
1421     if (SvIOKp(sv)) {
1422          if (SvUOK(sv)) {
1423               const UV uv = SvUV(sv);
1424               if (uv > IV_MAX)
1425                    count = IV_MAX; /* The best we can do? */
1426               else
1427                    count = uv;
1428          } else {
1429               const IV iv = SvIV(sv);
1430               if (iv < 0)
1431                    count = 0;
1432               else
1433                    count = iv;
1434          }
1435     }
1436     else if (SvNOKp(sv)) {
1437          const NV nv = SvNV(sv);
1438          if (nv < 0.0)
1439               count = 0;
1440          else
1441               count = (IV)nv;
1442     }
1443     else
1444          count = SvIVx(sv);
1445     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1446         dMARK;
1447         static const char oom_list_extend[] = "Out of memory during list extend";
1448         const I32 items = SP - MARK;
1449         const I32 max = items * count;
1450
1451         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1452         /* Did the max computation overflow? */
1453         if (items > 0 && max > 0 && (max < items || max < count))
1454            Perl_croak(aTHX_ oom_list_extend);
1455         MEXTEND(MARK, max);
1456         if (count > 1) {
1457             while (SP > MARK) {
1458 #if 0
1459               /* This code was intended to fix 20010809.028:
1460
1461                  $x = 'abcd';
1462                  for (($x =~ /./g) x 2) {
1463                      print chop; # "abcdabcd" expected as output.
1464                  }
1465
1466                * but that change (#11635) broke this code:
1467
1468                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1469
1470                * I can't think of a better fix that doesn't introduce
1471                * an efficiency hit by copying the SVs. The stack isn't
1472                * refcounted, and mortalisation obviously doesn't
1473                * Do The Right Thing when the stack has more than
1474                * one pointer to the same mortal value.
1475                * .robin.
1476                */
1477                 if (*SP) {
1478                     *SP = sv_2mortal(newSVsv(*SP));
1479                     SvREADONLY_on(*SP);
1480                 }
1481 #else
1482                if (*SP)
1483                    SvTEMP_off((*SP));
1484 #endif
1485                 SP--;
1486             }
1487             MARK++;
1488             repeatcpy((char*)(MARK + items), (char*)MARK,
1489                 items * sizeof(SV*), count - 1);
1490             SP += max;
1491         }
1492         else if (count <= 0)
1493             SP -= items;
1494     }
1495     else {      /* Note: mark already snarfed by pp_list */
1496         SV * const tmpstr = POPs;
1497         STRLEN len;
1498         bool isutf;
1499         static const char oom_string_extend[] =
1500           "Out of memory during string extend";
1501
1502         SvSetSV(TARG, tmpstr);
1503         SvPV_force(TARG, len);
1504         isutf = DO_UTF8(TARG);
1505         if (count != 1) {
1506             if (count < 1)
1507                 SvCUR_set(TARG, 0);
1508             else {
1509                 const STRLEN max = (UV)count * len;
1510                 if (len > ((MEM_SIZE)~0)/count)
1511                      Perl_croak(aTHX_ oom_string_extend);
1512                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1513                 SvGROW(TARG, max + 1);
1514                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1515                 SvCUR_set(TARG, SvCUR(TARG) * count);
1516             }
1517             *SvEND(TARG) = '\0';
1518         }
1519         if (isutf)
1520             (void)SvPOK_only_UTF8(TARG);
1521         else
1522             (void)SvPOK_only(TARG);
1523
1524         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1525             /* The parser saw this as a list repeat, and there
1526                are probably several items on the stack. But we're
1527                in scalar context, and there's no pp_list to save us
1528                now. So drop the rest of the items -- robin@kitsite.com
1529              */
1530             dMARK;
1531             SP = MARK;
1532         }
1533         PUSHTARG;
1534     }
1535     RETURN;
1536   }
1537 }
1538
1539 PP(pp_subtract)
1540 {
1541     dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1542     useleft = USE_LEFT(TOPm1s);
1543 #ifdef PERL_PRESERVE_IVUV
1544     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1545        "bad things" happen if you rely on signed integers wrapping.  */
1546     SvIV_please(TOPs);
1547     if (SvIOK(TOPs)) {
1548         /* Unless the left argument is integer in range we are going to have to
1549            use NV maths. Hence only attempt to coerce the right argument if
1550            we know the left is integer.  */
1551         register UV auv = 0;
1552         bool auvok = FALSE;
1553         bool a_valid = 0;
1554
1555         if (!useleft) {
1556             auv = 0;
1557             a_valid = auvok = 1;
1558             /* left operand is undef, treat as zero.  */
1559         } else {
1560             /* Left operand is defined, so is it IV? */
1561             SvIV_please(TOPm1s);
1562             if (SvIOK(TOPm1s)) {
1563                 if ((auvok = SvUOK(TOPm1s)))
1564                     auv = SvUVX(TOPm1s);
1565                 else {
1566                     register const IV aiv = SvIVX(TOPm1s);
1567                     if (aiv >= 0) {
1568                         auv = aiv;
1569                         auvok = 1;      /* Now acting as a sign flag.  */
1570                     } else { /* 2s complement assumption for IV_MIN */
1571                         auv = (UV)-aiv;
1572                     }
1573                 }
1574                 a_valid = 1;
1575             }
1576         }
1577         if (a_valid) {
1578             bool result_good = 0;
1579             UV result;
1580             register UV buv;
1581             bool buvok = SvUOK(TOPs);
1582
1583             if (buvok)
1584                 buv = SvUVX(TOPs);
1585             else {
1586                 register const IV biv = SvIVX(TOPs);
1587                 if (biv >= 0) {
1588                     buv = biv;
1589                     buvok = 1;
1590                 } else
1591                     buv = (UV)-biv;
1592             }
1593             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1594                else "IV" now, independent of how it came in.
1595                if a, b represents positive, A, B negative, a maps to -A etc
1596                a - b =>  (a - b)
1597                A - b => -(a + b)
1598                a - B =>  (a + b)
1599                A - B => -(a - b)
1600                all UV maths. negate result if A negative.
1601                subtract if signs same, add if signs differ. */
1602
1603             if (auvok ^ buvok) {
1604                 /* Signs differ.  */
1605                 result = auv + buv;
1606                 if (result >= auv)
1607                     result_good = 1;
1608             } else {
1609                 /* Signs same */
1610                 if (auv >= buv) {
1611                     result = auv - buv;
1612                     /* Must get smaller */
1613                     if (result <= auv)
1614                         result_good = 1;
1615                 } else {
1616                     result = buv - auv;
1617                     if (result <= buv) {
1618                         /* result really should be -(auv-buv). as its negation
1619                            of true value, need to swap our result flag  */
1620                         auvok = !auvok;
1621                         result_good = 1;
1622                     }
1623                 }
1624             }
1625             if (result_good) {
1626                 SP--;
1627                 if (auvok)
1628                     SETu( result );
1629                 else {
1630                     /* Negate result */
1631                     if (result <= (UV)IV_MIN)
1632                         SETi( -(IV)result );
1633                     else {
1634                         /* result valid, but out of range for IV.  */
1635                         SETn( -(NV)result );
1636                     }
1637                 }
1638                 RETURN;
1639             } /* Overflow, drop through to NVs.  */
1640         }
1641     }
1642 #endif
1643     useleft = USE_LEFT(TOPm1s);
1644     {
1645         dPOPnv;
1646         if (!useleft) {
1647             /* left operand is undef, treat as zero - value */
1648             SETn(-value);
1649             RETURN;
1650         }
1651         SETn( TOPn - value );
1652         RETURN;
1653     }
1654 }
1655
1656 PP(pp_left_shift)
1657 {
1658     dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1659     {
1660       const IV shift = POPi;
1661       if (PL_op->op_private & HINT_INTEGER) {
1662         const IV i = TOPi;
1663         SETi(i << shift);
1664       }
1665       else {
1666         const UV u = TOPu;
1667         SETu(u << shift);
1668       }
1669       RETURN;
1670     }
1671 }
1672
1673 PP(pp_right_shift)
1674 {
1675     dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1676     {
1677       const IV shift = POPi;
1678       if (PL_op->op_private & HINT_INTEGER) {
1679         const IV i = TOPi;
1680         SETi(i >> shift);
1681       }
1682       else {
1683         const UV u = TOPu;
1684         SETu(u >> shift);
1685       }
1686       RETURN;
1687     }
1688 }
1689
1690 PP(pp_lt)
1691 {
1692     dVAR; dSP; tryAMAGICbinSET(lt,0);
1693 #ifdef PERL_PRESERVE_IVUV
1694     SvIV_please(TOPs);
1695     if (SvIOK(TOPs)) {
1696         SvIV_please(TOPm1s);
1697         if (SvIOK(TOPm1s)) {
1698             bool auvok = SvUOK(TOPm1s);
1699             bool buvok = SvUOK(TOPs);
1700
1701             if (!auvok && !buvok) { /* ## IV < IV ## */
1702                 const IV aiv = SvIVX(TOPm1s);
1703                 const IV biv = SvIVX(TOPs);
1704
1705                 SP--;
1706                 SETs(boolSV(aiv < biv));
1707                 RETURN;
1708             }
1709             if (auvok && buvok) { /* ## UV < UV ## */
1710                 const UV auv = SvUVX(TOPm1s);
1711                 const UV buv = SvUVX(TOPs);
1712
1713                 SP--;
1714                 SETs(boolSV(auv < buv));
1715                 RETURN;
1716             }
1717             if (auvok) { /* ## UV < IV ## */
1718                 UV auv;
1719                 const IV biv = SvIVX(TOPs);
1720                 SP--;
1721                 if (biv < 0) {
1722                     /* As (a) is a UV, it's >=0, so it cannot be < */
1723                     SETs(&PL_sv_no);
1724                     RETURN;
1725                 }
1726                 auv = SvUVX(TOPs);
1727                 SETs(boolSV(auv < (UV)biv));
1728                 RETURN;
1729             }
1730             { /* ## IV < UV ## */
1731                 const IV aiv = SvIVX(TOPm1s);
1732                 UV buv;
1733
1734                 if (aiv < 0) {
1735                     /* As (b) is a UV, it's >=0, so it must be < */
1736                     SP--;
1737                     SETs(&PL_sv_yes);
1738                     RETURN;
1739                 }
1740                 buv = SvUVX(TOPs);
1741                 SP--;
1742                 SETs(boolSV((UV)aiv < buv));
1743                 RETURN;
1744             }
1745         }
1746     }
1747 #endif
1748 #ifndef NV_PRESERVES_UV
1749 #ifdef PERL_PRESERVE_IVUV
1750     else
1751 #endif
1752     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1753         SP--;
1754         SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1755         RETURN;
1756     }
1757 #endif
1758     {
1759 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1760       dPOPTOPnnrl;
1761       if (Perl_isnan(left) || Perl_isnan(right))
1762           RETSETNO;
1763       SETs(boolSV(left < right));
1764 #else
1765       dPOPnv;
1766       SETs(boolSV(TOPn < value));
1767 #endif
1768       RETURN;
1769     }
1770 }
1771
1772 PP(pp_gt)
1773 {
1774     dVAR; dSP; tryAMAGICbinSET(gt,0);
1775 #ifdef PERL_PRESERVE_IVUV
1776     SvIV_please(TOPs);
1777     if (SvIOK(TOPs)) {
1778         SvIV_please(TOPm1s);
1779         if (SvIOK(TOPm1s)) {
1780             bool auvok = SvUOK(TOPm1s);
1781             bool buvok = SvUOK(TOPs);
1782
1783             if (!auvok && !buvok) { /* ## IV > IV ## */
1784                 const IV aiv = SvIVX(TOPm1s);
1785                 const IV biv = SvIVX(TOPs);
1786
1787                 SP--;
1788                 SETs(boolSV(aiv > biv));
1789                 RETURN;
1790             }
1791             if (auvok && buvok) { /* ## UV > UV ## */
1792                 const UV auv = SvUVX(TOPm1s);
1793                 const UV buv = SvUVX(TOPs);
1794
1795                 SP--;
1796                 SETs(boolSV(auv > buv));
1797                 RETURN;
1798             }
1799             if (auvok) { /* ## UV > IV ## */
1800                 UV auv;
1801                 const IV biv = SvIVX(TOPs);
1802
1803                 SP--;
1804                 if (biv < 0) {
1805                     /* As (a) is a UV, it's >=0, so it must be > */
1806                     SETs(&PL_sv_yes);
1807                     RETURN;
1808                 }
1809                 auv = SvUVX(TOPs);
1810                 SETs(boolSV(auv > (UV)biv));
1811                 RETURN;
1812             }
1813             { /* ## IV > UV ## */
1814                 const IV aiv = SvIVX(TOPm1s);
1815                 UV buv;
1816
1817                 if (aiv < 0) {
1818                     /* As (b) is a UV, it's >=0, so it cannot be > */
1819                     SP--;
1820                     SETs(&PL_sv_no);
1821                     RETURN;
1822                 }
1823                 buv = SvUVX(TOPs);
1824                 SP--;
1825                 SETs(boolSV((UV)aiv > buv));
1826                 RETURN;
1827             }
1828         }
1829     }
1830 #endif
1831 #ifndef NV_PRESERVES_UV
1832 #ifdef PERL_PRESERVE_IVUV
1833     else
1834 #endif
1835     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1836         SP--;
1837         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1838         RETURN;
1839     }
1840 #endif
1841     {
1842 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1843       dPOPTOPnnrl;
1844       if (Perl_isnan(left) || Perl_isnan(right))
1845           RETSETNO;
1846       SETs(boolSV(left > right));
1847 #else
1848       dPOPnv;
1849       SETs(boolSV(TOPn > value));
1850 #endif
1851       RETURN;
1852     }
1853 }
1854
1855 PP(pp_le)
1856 {
1857     dVAR; dSP; tryAMAGICbinSET(le,0);
1858 #ifdef PERL_PRESERVE_IVUV
1859     SvIV_please(TOPs);
1860     if (SvIOK(TOPs)) {
1861         SvIV_please(TOPm1s);
1862         if (SvIOK(TOPm1s)) {
1863             bool auvok = SvUOK(TOPm1s);
1864             bool buvok = SvUOK(TOPs);
1865
1866             if (!auvok && !buvok) { /* ## IV <= IV ## */
1867                 const IV aiv = SvIVX(TOPm1s);
1868                 const IV biv = SvIVX(TOPs);
1869
1870                 SP--;
1871                 SETs(boolSV(aiv <= biv));
1872                 RETURN;
1873             }
1874             if (auvok && buvok) { /* ## UV <= UV ## */
1875                 UV auv = SvUVX(TOPm1s);
1876                 UV buv = SvUVX(TOPs);
1877
1878                 SP--;
1879                 SETs(boolSV(auv <= buv));
1880                 RETURN;
1881             }
1882             if (auvok) { /* ## UV <= IV ## */
1883                 UV auv;
1884                 const IV biv = SvIVX(TOPs);
1885
1886                 SP--;
1887                 if (biv < 0) {
1888                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1889                     SETs(&PL_sv_no);
1890                     RETURN;
1891                 }
1892                 auv = SvUVX(TOPs);
1893                 SETs(boolSV(auv <= (UV)biv));
1894                 RETURN;
1895             }
1896             { /* ## IV <= UV ## */
1897                 const IV aiv = SvIVX(TOPm1s);
1898                 UV buv;
1899
1900                 if (aiv < 0) {
1901                     /* As (b) is a UV, it's >=0, so a must be <= */
1902                     SP--;
1903                     SETs(&PL_sv_yes);
1904                     RETURN;
1905                 }
1906                 buv = SvUVX(TOPs);
1907                 SP--;
1908                 SETs(boolSV((UV)aiv <= buv));
1909                 RETURN;
1910             }
1911         }
1912     }
1913 #endif
1914 #ifndef NV_PRESERVES_UV
1915 #ifdef PERL_PRESERVE_IVUV
1916     else
1917 #endif
1918     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1919         SP--;
1920         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1921         RETURN;
1922     }
1923 #endif
1924     {
1925 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1926       dPOPTOPnnrl;
1927       if (Perl_isnan(left) || Perl_isnan(right))
1928           RETSETNO;
1929       SETs(boolSV(left <= right));
1930 #else
1931       dPOPnv;
1932       SETs(boolSV(TOPn <= value));
1933 #endif
1934       RETURN;
1935     }
1936 }
1937
1938 PP(pp_ge)
1939 {
1940     dVAR; dSP; tryAMAGICbinSET(ge,0);
1941 #ifdef PERL_PRESERVE_IVUV
1942     SvIV_please(TOPs);
1943     if (SvIOK(TOPs)) {
1944         SvIV_please(TOPm1s);
1945         if (SvIOK(TOPm1s)) {
1946             bool auvok = SvUOK(TOPm1s);
1947             bool buvok = SvUOK(TOPs);
1948
1949             if (!auvok && !buvok) { /* ## IV >= IV ## */
1950                 const IV aiv = SvIVX(TOPm1s);
1951                 const IV biv = SvIVX(TOPs);
1952
1953                 SP--;
1954                 SETs(boolSV(aiv >= biv));
1955                 RETURN;
1956             }
1957             if (auvok && buvok) { /* ## UV >= UV ## */
1958                 const UV auv = SvUVX(TOPm1s);
1959                 const UV buv = SvUVX(TOPs);
1960
1961                 SP--;
1962                 SETs(boolSV(auv >= buv));
1963                 RETURN;
1964             }
1965             if (auvok) { /* ## UV >= IV ## */
1966                 UV auv;
1967                 const IV biv = SvIVX(TOPs);
1968
1969                 SP--;
1970                 if (biv < 0) {
1971                     /* As (a) is a UV, it's >=0, so it must be >= */
1972                     SETs(&PL_sv_yes);
1973                     RETURN;
1974                 }
1975                 auv = SvUVX(TOPs);
1976                 SETs(boolSV(auv >= (UV)biv));
1977                 RETURN;
1978             }
1979             { /* ## IV >= UV ## */
1980                 const IV aiv = SvIVX(TOPm1s);
1981                 UV buv;
1982
1983                 if (aiv < 0) {
1984                     /* As (b) is a UV, it's >=0, so a cannot be >= */
1985                     SP--;
1986                     SETs(&PL_sv_no);
1987                     RETURN;
1988                 }
1989                 buv = SvUVX(TOPs);
1990                 SP--;
1991                 SETs(boolSV((UV)aiv >= buv));
1992                 RETURN;
1993             }
1994         }
1995     }
1996 #endif
1997 #ifndef NV_PRESERVES_UV
1998 #ifdef PERL_PRESERVE_IVUV
1999     else
2000 #endif
2001     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2002         SP--;
2003         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2004         RETURN;
2005     }
2006 #endif
2007     {
2008 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2009       dPOPTOPnnrl;
2010       if (Perl_isnan(left) || Perl_isnan(right))
2011           RETSETNO;
2012       SETs(boolSV(left >= right));
2013 #else
2014       dPOPnv;
2015       SETs(boolSV(TOPn >= value));
2016 #endif
2017       RETURN;
2018     }
2019 }
2020
2021 PP(pp_ne)
2022 {
2023     dVAR; dSP; tryAMAGICbinSET(ne,0);
2024 #ifndef NV_PRESERVES_UV
2025     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2026         SP--;
2027         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2028         RETURN;
2029     }
2030 #endif
2031 #ifdef PERL_PRESERVE_IVUV
2032     SvIV_please(TOPs);
2033     if (SvIOK(TOPs)) {
2034         SvIV_please(TOPm1s);
2035         if (SvIOK(TOPm1s)) {
2036             const bool auvok = SvUOK(TOPm1s);
2037             const bool buvok = SvUOK(TOPs);
2038
2039             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2040                 /* Casting IV to UV before comparison isn't going to matter
2041                    on 2s complement. On 1s complement or sign&magnitude
2042                    (if we have any of them) it could make negative zero
2043                    differ from normal zero. As I understand it. (Need to
2044                    check - is negative zero implementation defined behaviour
2045                    anyway?). NWC  */
2046                 const UV buv = SvUVX(POPs);
2047                 const UV auv = SvUVX(TOPs);
2048
2049                 SETs(boolSV(auv != buv));
2050                 RETURN;
2051             }
2052             {                   /* ## Mixed IV,UV ## */
2053                 IV iv;
2054                 UV uv;
2055
2056                 /* != is commutative so swap if needed (save code) */
2057                 if (auvok) {
2058                     /* swap. top of stack (b) is the iv */
2059                     iv = SvIVX(TOPs);
2060                     SP--;
2061                     if (iv < 0) {
2062                         /* As (a) is a UV, it's >0, so it cannot be == */
2063                         SETs(&PL_sv_yes);
2064                         RETURN;
2065                     }
2066                     uv = SvUVX(TOPs);
2067                 } else {
2068                     iv = SvIVX(TOPm1s);
2069                     SP--;
2070                     if (iv < 0) {
2071                         /* As (b) is a UV, it's >0, so it cannot be == */
2072                         SETs(&PL_sv_yes);
2073                         RETURN;
2074                     }
2075                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2076                 }
2077                 SETs(boolSV((UV)iv != uv));
2078                 RETURN;
2079             }
2080         }
2081     }
2082 #endif
2083     {
2084 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2085       dPOPTOPnnrl;
2086       if (Perl_isnan(left) || Perl_isnan(right))
2087           RETSETYES;
2088       SETs(boolSV(left != right));
2089 #else
2090       dPOPnv;
2091       SETs(boolSV(TOPn != value));
2092 #endif
2093       RETURN;
2094     }
2095 }
2096
2097 PP(pp_ncmp)
2098 {
2099     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2100 #ifndef NV_PRESERVES_UV
2101     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2102         const UV right = PTR2UV(SvRV(POPs));
2103         const UV left = PTR2UV(SvRV(TOPs));
2104         SETi((left > right) - (left < right));
2105         RETURN;
2106     }
2107 #endif
2108 #ifdef PERL_PRESERVE_IVUV
2109     /* Fortunately it seems NaN isn't IOK */
2110     SvIV_please(TOPs);
2111     if (SvIOK(TOPs)) {
2112         SvIV_please(TOPm1s);
2113         if (SvIOK(TOPm1s)) {
2114             const bool leftuvok = SvUOK(TOPm1s);
2115             const bool rightuvok = SvUOK(TOPs);
2116             I32 value;
2117             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2118                 const IV leftiv = SvIVX(TOPm1s);
2119                 const IV rightiv = SvIVX(TOPs);
2120
2121                 if (leftiv > rightiv)
2122                     value = 1;
2123                 else if (leftiv < rightiv)
2124                     value = -1;
2125                 else
2126                     value = 0;
2127             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2128                 const UV leftuv = SvUVX(TOPm1s);
2129                 const UV rightuv = SvUVX(TOPs);
2130
2131                 if (leftuv > rightuv)
2132                     value = 1;
2133                 else if (leftuv < rightuv)
2134                     value = -1;
2135                 else
2136                     value = 0;
2137             } else if (leftuvok) { /* ## UV <=> IV ## */
2138                 const IV rightiv = SvIVX(TOPs);
2139                 if (rightiv < 0) {
2140                     /* As (a) is a UV, it's >=0, so it cannot be < */
2141                     value = 1;
2142                 } else {
2143                     const UV leftuv = SvUVX(TOPm1s);
2144                     if (leftuv > (UV)rightiv) {
2145                         value = 1;
2146                     } else if (leftuv < (UV)rightiv) {
2147                         value = -1;
2148                     } else {
2149                         value = 0;
2150                     }
2151                 }
2152             } else { /* ## IV <=> UV ## */
2153                 const IV leftiv = SvIVX(TOPm1s);
2154                 if (leftiv < 0) {
2155                     /* As (b) is a UV, it's >=0, so it must be < */
2156                     value = -1;
2157                 } else {
2158                     const UV rightuv = SvUVX(TOPs);
2159                     if ((UV)leftiv > rightuv) {
2160                         value = 1;
2161                     } else if ((UV)leftiv < rightuv) {
2162                         value = -1;
2163                     } else {
2164                         value = 0;
2165                     }
2166                 }
2167             }
2168             SP--;
2169             SETi(value);
2170             RETURN;
2171         }
2172     }
2173 #endif
2174     {
2175       dPOPTOPnnrl;
2176       I32 value;
2177
2178 #ifdef Perl_isnan
2179       if (Perl_isnan(left) || Perl_isnan(right)) {
2180           SETs(&PL_sv_undef);
2181           RETURN;
2182        }
2183       value = (left > right) - (left < right);
2184 #else
2185       if (left == right)
2186         value = 0;
2187       else if (left < right)
2188         value = -1;
2189       else if (left > right)
2190         value = 1;
2191       else {
2192         SETs(&PL_sv_undef);
2193         RETURN;
2194       }
2195 #endif
2196       SETi(value);
2197       RETURN;
2198     }
2199 }
2200
2201 PP(pp_sle)
2202 {
2203     dVAR; dSP;
2204
2205     int amg_type = sle_amg;
2206     int multiplier = 1;
2207     int rhs = 1;
2208
2209     switch (PL_op->op_type) {
2210     case OP_SLT:
2211         amg_type = slt_amg;
2212         /* cmp < 0 */
2213         rhs = 0;
2214         break;
2215     case OP_SGT:
2216         amg_type = sgt_amg;
2217         /* cmp > 0 */
2218         multiplier = -1;
2219         rhs = 0;
2220         break;
2221     case OP_SGE:
2222         amg_type = sge_amg;
2223         /* cmp >= 0 */
2224         multiplier = -1;
2225         break;
2226     }
2227
2228     tryAMAGICbinSET_var(amg_type,0);
2229     {
2230       dPOPTOPssrl;
2231       const int cmp = (IN_LOCALE_RUNTIME
2232                  ? sv_cmp_locale(left, right)
2233                  : sv_cmp(left, right));
2234       SETs(boolSV(cmp * multiplier < rhs));
2235       RETURN;
2236     }
2237 }
2238
2239 PP(pp_seq)
2240 {
2241     dVAR; dSP; tryAMAGICbinSET(seq,0);
2242     {
2243       dPOPTOPssrl;
2244       SETs(boolSV(sv_eq(left, right)));
2245       RETURN;
2246     }
2247 }
2248
2249 PP(pp_sne)
2250 {
2251     dVAR; dSP; tryAMAGICbinSET(sne,0);
2252     {
2253       dPOPTOPssrl;
2254       SETs(boolSV(!sv_eq(left, right)));
2255       RETURN;
2256     }
2257 }
2258
2259 PP(pp_scmp)
2260 {
2261     dVAR; dSP; dTARGET;  tryAMAGICbin(scmp,0);
2262     {
2263       dPOPTOPssrl;
2264       const int cmp = (IN_LOCALE_RUNTIME
2265                  ? sv_cmp_locale(left, right)
2266                  : sv_cmp(left, right));
2267       SETi( cmp );
2268       RETURN;
2269     }
2270 }
2271
2272 PP(pp_bit_and)
2273 {
2274     dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2275     {
2276       dPOPTOPssrl;
2277       SvGETMAGIC(left);
2278       SvGETMAGIC(right);
2279       if (SvNIOKp(left) || SvNIOKp(right)) {
2280         if (PL_op->op_private & HINT_INTEGER) {
2281           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2282           SETi(i);
2283         }
2284         else {
2285           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2286           SETu(u);
2287         }
2288       }
2289       else {
2290         do_vop(PL_op->op_type, TARG, left, right);
2291         SETTARG;
2292       }
2293       RETURN;
2294     }
2295 }
2296
2297 PP(pp_bit_or)
2298 {
2299     dVAR; dSP; dATARGET;
2300     const int op_type = PL_op->op_type;
2301
2302     tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2303     {
2304       dPOPTOPssrl;
2305       SvGETMAGIC(left);
2306       SvGETMAGIC(right);
2307       if (SvNIOKp(left) || SvNIOKp(right)) {
2308         if (PL_op->op_private & HINT_INTEGER) {
2309           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2310           const IV r = SvIV_nomg(right);
2311           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2312           SETi(result);
2313         }
2314         else {
2315           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2316           const UV r = SvUV_nomg(right);
2317           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2318           SETu(result);
2319         }
2320       }
2321       else {
2322         do_vop(op_type, TARG, left, right);
2323         SETTARG;
2324       }
2325       RETURN;
2326     }
2327 }
2328
2329 PP(pp_negate)
2330 {
2331     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2332     {
2333         dTOPss;
2334         const int flags = SvFLAGS(sv);
2335         SvGETMAGIC(sv);
2336         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2337             /* It's publicly an integer, or privately an integer-not-float */
2338         oops_its_an_int:
2339             if (SvIsUV(sv)) {
2340                 if (SvIVX(sv) == IV_MIN) {
2341                     /* 2s complement assumption. */
2342                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2343                     RETURN;
2344                 }
2345                 else if (SvUVX(sv) <= IV_MAX) {
2346                     SETi(-SvIVX(sv));
2347                     RETURN;
2348                 }
2349             }
2350             else if (SvIVX(sv) != IV_MIN) {
2351                 SETi(-SvIVX(sv));
2352                 RETURN;
2353             }
2354 #ifdef PERL_PRESERVE_IVUV
2355             else {
2356                 SETu((UV)IV_MIN);
2357                 RETURN;
2358             }
2359 #endif
2360         }
2361         if (SvNIOKp(sv))
2362             SETn(-SvNV(sv));
2363         else if (SvPOKp(sv)) {
2364             STRLEN len;
2365             const char * const s = SvPV_const(sv, len);
2366             if (isIDFIRST(*s)) {
2367                 sv_setpvn(TARG, "-", 1);
2368                 sv_catsv(TARG, sv);
2369             }
2370             else if (*s == '+' || *s == '-') {
2371                 sv_setsv(TARG, sv);
2372                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2373             }
2374             else if (DO_UTF8(sv)) {
2375                 SvIV_please(sv);
2376                 if (SvIOK(sv))
2377                     goto oops_its_an_int;
2378                 if (SvNOK(sv))
2379                     sv_setnv(TARG, -SvNV(sv));
2380                 else {
2381                     sv_setpvn(TARG, "-", 1);
2382                     sv_catsv(TARG, sv);
2383                 }
2384             }
2385             else {
2386                 SvIV_please(sv);
2387                 if (SvIOK(sv))
2388                   goto oops_its_an_int;
2389                 sv_setnv(TARG, -SvNV(sv));
2390             }
2391             SETTARG;
2392         }
2393         else
2394             SETn(-SvNV(sv));
2395     }
2396     RETURN;
2397 }
2398
2399 PP(pp_not)
2400 {
2401     dVAR; dSP; tryAMAGICunSET(not);
2402     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2403     return NORMAL;
2404 }
2405
2406 PP(pp_complement)
2407 {
2408     dVAR; dSP; dTARGET; tryAMAGICun(compl);
2409     {
2410       dTOPss;
2411       SvGETMAGIC(sv);
2412       if (SvNIOKp(sv)) {
2413         if (PL_op->op_private & HINT_INTEGER) {
2414           const IV i = ~SvIV_nomg(sv);
2415           SETi(i);
2416         }
2417         else {
2418           const UV u = ~SvUV_nomg(sv);
2419           SETu(u);
2420         }
2421       }
2422       else {
2423         register U8 *tmps;
2424         register I32 anum;
2425         STRLEN len;
2426
2427         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2428         sv_setsv_nomg(TARG, sv);
2429         tmps = (U8*)SvPV_force(TARG, len);
2430         anum = len;
2431         if (SvUTF8(TARG)) {
2432           /* Calculate exact length, let's not estimate. */
2433           STRLEN targlen = 0;
2434           STRLEN l;
2435           UV nchar = 0;
2436           UV nwide = 0;
2437           U8 * const send = tmps + len;
2438           U8 * const origtmps = tmps;
2439           const UV utf8flags = UTF8_ALLOW_ANYUV;
2440
2441           while (tmps < send) {
2442             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2443             tmps += l;
2444             targlen += UNISKIP(~c);
2445             nchar++;
2446             if (c > 0xff)
2447                 nwide++;
2448           }
2449
2450           /* Now rewind strings and write them. */
2451           tmps = origtmps;
2452
2453           if (nwide) {
2454               U8 *result;
2455               U8 *p;
2456
2457               Newx(result, targlen + 1, U8);
2458               p = result;
2459               while (tmps < send) {
2460                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2461                   tmps += l;
2462                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2463               }
2464               *p = '\0';
2465               sv_usepvn_flags(TARG, (char*)result, targlen,
2466                               SV_HAS_TRAILING_NUL);
2467               SvUTF8_on(TARG);
2468           }
2469           else {
2470               U8 *result;
2471               U8 *p;
2472
2473               Newx(result, nchar + 1, U8);
2474               p = result;
2475               while (tmps < send) {
2476                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2477                   tmps += l;
2478                   *p++ = ~c;
2479               }
2480               *p = '\0';
2481               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2482               SvUTF8_off(TARG);
2483           }
2484           SETs(TARG);
2485           RETURN;
2486         }
2487 #ifdef LIBERAL
2488         {
2489             register long *tmpl;
2490             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2491                 *tmps = ~*tmps;
2492             tmpl = (long*)tmps;
2493             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2494                 *tmpl = ~*tmpl;
2495             tmps = (U8*)tmpl;
2496         }
2497 #endif
2498         for ( ; anum > 0; anum--, tmps++)
2499             *tmps = ~*tmps;
2500
2501         SETs(TARG);
2502       }
2503       RETURN;
2504     }
2505 }
2506
2507 /* integer versions of some of the above */
2508
2509 PP(pp_i_multiply)
2510 {
2511     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2512     {
2513       dPOPTOPiirl;
2514       SETi( left * right );
2515       RETURN;
2516     }
2517 }
2518
2519 PP(pp_i_divide)
2520 {
2521     IV num;
2522     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2523     {
2524       dPOPiv;
2525       if (value == 0)
2526           DIE(aTHX_ "Illegal division by zero");
2527       num = POPi;
2528
2529       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2530       if (value == -1)
2531           value = - num;
2532       else
2533           value = num / value;
2534       PUSHi( value );
2535       RETURN;
2536     }
2537 }
2538
2539 STATIC
2540 PP(pp_i_modulo_0)
2541 {
2542      /* This is the vanilla old i_modulo. */
2543      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2544      {
2545           dPOPTOPiirl;
2546           if (!right)
2547                DIE(aTHX_ "Illegal modulus zero");
2548           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2549           if (right == -1)
2550               SETi( 0 );
2551           else
2552               SETi( left % right );
2553           RETURN;
2554      }
2555 }
2556
2557 #if defined(__GLIBC__) && IVSIZE == 8
2558 STATIC
2559 PP(pp_i_modulo_1)
2560 {
2561      /* This is the i_modulo with the workaround for the _moddi3 bug
2562       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2563       * See below for pp_i_modulo. */
2564      dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2565      {
2566           dPOPTOPiirl;
2567           if (!right)
2568                DIE(aTHX_ "Illegal modulus zero");
2569           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2570           if (right == -1)
2571               SETi( 0 );
2572           else
2573               SETi( left % PERL_ABS(right) );
2574           RETURN;
2575      }
2576 }
2577 #endif
2578
2579 PP(pp_i_modulo)
2580 {
2581      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2582      {
2583           dPOPTOPiirl;
2584           if (!right)
2585                DIE(aTHX_ "Illegal modulus zero");
2586           /* The assumption is to use hereafter the old vanilla version... */
2587           PL_op->op_ppaddr =
2588                PL_ppaddr[OP_I_MODULO] =
2589                    Perl_pp_i_modulo_0;
2590           /* .. but if we have glibc, we might have a buggy _moddi3
2591            * (at least glicb 2.2.5 is known to have this bug), in other
2592            * words our integer modulus with negative quad as the second
2593            * argument might be broken.  Test for this and re-patch the
2594            * opcode dispatch table if that is the case, remembering to
2595            * also apply the workaround so that this first round works
2596            * right, too.  See [perl #9402] for more information. */
2597 #if defined(__GLIBC__) && IVSIZE == 8
2598           {
2599                IV l =   3;
2600                IV r = -10;
2601                /* Cannot do this check with inlined IV constants since
2602                 * that seems to work correctly even with the buggy glibc. */
2603                if (l % r == -3) {
2604                     /* Yikes, we have the bug.
2605                      * Patch in the workaround version. */
2606                     PL_op->op_ppaddr =
2607                          PL_ppaddr[OP_I_MODULO] =
2608                              &Perl_pp_i_modulo_1;
2609                     /* Make certain we work right this time, too. */
2610                     right = PERL_ABS(right);
2611                }
2612           }
2613 #endif
2614           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2615           if (right == -1)
2616               SETi( 0 );
2617           else
2618               SETi( left % right );
2619           RETURN;
2620      }
2621 }
2622
2623 PP(pp_i_add)
2624 {
2625     dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2626     {
2627       dPOPTOPiirl_ul;
2628       SETi( left + right );
2629       RETURN;
2630     }
2631 }
2632
2633 PP(pp_i_subtract)
2634 {
2635     dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2636     {
2637       dPOPTOPiirl_ul;
2638       SETi( left - right );
2639       RETURN;
2640     }
2641 }
2642
2643 PP(pp_i_lt)
2644 {
2645     dVAR; dSP; tryAMAGICbinSET(lt,0);
2646     {
2647       dPOPTOPiirl;
2648       SETs(boolSV(left < right));
2649       RETURN;
2650     }
2651 }
2652
2653 PP(pp_i_gt)
2654 {
2655     dVAR; dSP; tryAMAGICbinSET(gt,0);
2656     {
2657       dPOPTOPiirl;
2658       SETs(boolSV(left > right));
2659       RETURN;
2660     }
2661 }
2662
2663 PP(pp_i_le)
2664 {
2665     dVAR; dSP; tryAMAGICbinSET(le,0);
2666     {
2667       dPOPTOPiirl;
2668       SETs(boolSV(left <= right));
2669       RETURN;
2670     }
2671 }
2672
2673 PP(pp_i_ge)
2674 {
2675     dVAR; dSP; tryAMAGICbinSET(ge,0);
2676     {
2677       dPOPTOPiirl;
2678       SETs(boolSV(left >= right));
2679       RETURN;
2680     }
2681 }
2682
2683 PP(pp_i_eq)
2684 {
2685     dVAR; dSP; tryAMAGICbinSET(eq,0);
2686     {
2687       dPOPTOPiirl;
2688       SETs(boolSV(left == right));
2689       RETURN;
2690     }
2691 }
2692
2693 PP(pp_i_ne)
2694 {
2695     dVAR; dSP; tryAMAGICbinSET(ne,0);
2696     {
2697       dPOPTOPiirl;
2698       SETs(boolSV(left != right));
2699       RETURN;
2700     }
2701 }
2702
2703 PP(pp_i_ncmp)
2704 {
2705     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2706     {
2707       dPOPTOPiirl;
2708       I32 value;
2709
2710       if (left > right)
2711         value = 1;
2712       else if (left < right)
2713         value = -1;
2714       else
2715         value = 0;
2716       SETi(value);
2717       RETURN;
2718     }
2719 }
2720
2721 PP(pp_i_negate)
2722 {
2723     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2724     SETi(-TOPi);
2725     RETURN;
2726 }
2727
2728 /* High falutin' math. */
2729
2730 PP(pp_atan2)
2731 {
2732     dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2733     {
2734       dPOPTOPnnrl;
2735       SETn(Perl_atan2(left, right));
2736       RETURN;
2737     }
2738 }
2739
2740 PP(pp_sin)
2741 {
2742     dVAR; dSP; dTARGET;
2743     int amg_type = sin_amg;
2744     const char *neg_report = NULL;
2745     NV (*func)(NV) = Perl_sin;
2746     const int op_type = PL_op->op_type;
2747
2748     switch (op_type) {
2749     case OP_COS:
2750         amg_type = cos_amg;
2751         func = Perl_cos;
2752         break;
2753     case OP_EXP:
2754         amg_type = exp_amg;
2755         func = Perl_exp;
2756         break;
2757     case OP_LOG:
2758         amg_type = log_amg;
2759         func = Perl_log;
2760         neg_report = "log";
2761         break;
2762     case OP_SQRT:
2763         amg_type = sqrt_amg;
2764         func = Perl_sqrt;
2765         neg_report = "sqrt";
2766         break;
2767     }
2768
2769     tryAMAGICun_var(amg_type);
2770     {
2771       const NV value = POPn;
2772       if (neg_report) {
2773           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2774               SET_NUMERIC_STANDARD();
2775               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2776           }
2777       }
2778       XPUSHn(func(value));
2779       RETURN;
2780     }
2781 }
2782
2783 /* Support Configure command-line overrides for rand() functions.
2784    After 5.005, perhaps we should replace this by Configure support
2785    for drand48(), random(), or rand().  For 5.005, though, maintain
2786    compatibility by calling rand() but allow the user to override it.
2787    See INSTALL for details.  --Andy Dougherty  15 July 1998
2788 */
2789 /* Now it's after 5.005, and Configure supports drand48() and random(),
2790    in addition to rand().  So the overrides should not be needed any more.
2791    --Jarkko Hietaniemi  27 September 1998
2792  */
2793
2794 #ifndef HAS_DRAND48_PROTO
2795 extern double drand48 (void);
2796 #endif
2797
2798 PP(pp_rand)
2799 {
2800     dVAR; dSP; dTARGET;
2801     NV value;
2802     if (MAXARG < 1)
2803         value = 1.0;
2804     else
2805         value = POPn;
2806     if (value == 0.0)
2807         value = 1.0;
2808     if (!PL_srand_called) {
2809         (void)seedDrand01((Rand_seed_t)seed());
2810         PL_srand_called = TRUE;
2811     }
2812     value *= Drand01();
2813     XPUSHn(value);
2814     RETURN;
2815 }
2816
2817 PP(pp_srand)
2818 {
2819     dVAR; dSP;
2820     const UV anum = (MAXARG < 1) ? seed() : POPu;
2821     (void)seedDrand01((Rand_seed_t)anum);
2822     PL_srand_called = TRUE;
2823     EXTEND(SP, 1);
2824     RETPUSHYES;
2825 }
2826
2827 PP(pp_int)
2828 {
2829     dVAR; dSP; dTARGET; tryAMAGICun(int);
2830     {
2831       const IV iv = TOPi; /* attempt to convert to IV if possible. */
2832       /* XXX it's arguable that compiler casting to IV might be subtly
2833          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2834          else preferring IV has introduced a subtle behaviour change bug. OTOH
2835          relying on floating point to be accurate is a bug.  */
2836
2837       if (!SvOK(TOPs))
2838         SETu(0);
2839       else if (SvIOK(TOPs)) {
2840         if (SvIsUV(TOPs)) {
2841             const UV uv = TOPu;
2842             SETu(uv);
2843         } else
2844             SETi(iv);
2845       } else {
2846           const NV value = TOPn;
2847           if (value >= 0.0) {
2848               if (value < (NV)UV_MAX + 0.5) {
2849                   SETu(U_V(value));
2850               } else {
2851                   SETn(Perl_floor(value));
2852               }
2853           }
2854           else {
2855               if (value > (NV)IV_MIN - 0.5) {
2856                   SETi(I_V(value));
2857               } else {
2858                   SETn(Perl_ceil(value));
2859               }
2860           }
2861       }
2862     }
2863     RETURN;
2864 }
2865
2866 PP(pp_abs)
2867 {
2868     dVAR; dSP; dTARGET; tryAMAGICun(abs);
2869     {
2870       /* This will cache the NV value if string isn't actually integer  */
2871       const IV iv = TOPi;
2872
2873       if (!SvOK(TOPs))
2874         SETu(0);
2875       else if (SvIOK(TOPs)) {
2876         /* IVX is precise  */
2877         if (SvIsUV(TOPs)) {
2878           SETu(TOPu);   /* force it to be numeric only */
2879         } else {
2880           if (iv >= 0) {
2881             SETi(iv);
2882           } else {
2883             if (iv != IV_MIN) {
2884               SETi(-iv);
2885             } else {
2886               /* 2s complement assumption. Also, not really needed as
2887                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2888               SETu(IV_MIN);
2889             }
2890           }
2891         }
2892       } else{
2893         const NV value = TOPn;
2894         if (value < 0.0)
2895           SETn(-value);
2896         else
2897           SETn(value);
2898       }
2899     }
2900     RETURN;
2901 }
2902
2903 PP(pp_oct)
2904 {
2905     dVAR; dSP; dTARGET;
2906     const char *tmps;
2907     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2908     STRLEN len;
2909     NV result_nv;
2910     UV result_uv;
2911     SV* const sv = POPs;
2912
2913     tmps = (SvPV_const(sv, len));
2914     if (DO_UTF8(sv)) {
2915          /* If Unicode, try to downgrade
2916           * If not possible, croak. */
2917          SV* const tsv = sv_2mortal(newSVsv(sv));
2918
2919          SvUTF8_on(tsv);
2920          sv_utf8_downgrade(tsv, FALSE);
2921          tmps = SvPV_const(tsv, len);
2922     }
2923     if (PL_op->op_type == OP_HEX)
2924         goto hex;
2925
2926     while (*tmps && len && isSPACE(*tmps))
2927         tmps++, len--;
2928     if (*tmps == '0')
2929         tmps++, len--;
2930     if (*tmps == 'x') {
2931     hex:
2932         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2933     }
2934     else if (*tmps == 'b')
2935         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2936     else
2937         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2938
2939     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2940         XPUSHn(result_nv);
2941     }
2942     else {
2943         XPUSHu(result_uv);
2944     }
2945     RETURN;
2946 }
2947
2948 /* String stuff. */
2949
2950 PP(pp_length)
2951 {
2952     dVAR; dSP; dTARGET;
2953     SV * const sv = TOPs;
2954
2955     if (SvAMAGIC(sv)) {
2956         /* For an overloaded scalar, we can't know in advance if it's going to
2957            be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2958            cache the length. Maybe that should be a documented feature of it.
2959         */
2960         STRLEN len;
2961         const char *const p = SvPV_const(sv, len);
2962
2963         if (DO_UTF8(sv)) {
2964             SETi(utf8_length((U8*)p, (U8*)p + len));
2965         }
2966         else
2967             SETi(len);
2968
2969     }
2970     else if (DO_UTF8(sv))
2971         SETi(sv_len_utf8(sv));
2972     else
2973         SETi(sv_len(sv));
2974     RETURN;
2975 }
2976
2977 PP(pp_substr)
2978 {
2979     dVAR; dSP; dTARGET;
2980     SV *sv;
2981     I32 len = 0;
2982     STRLEN curlen;
2983     STRLEN utf8_curlen;
2984     I32 pos;
2985     I32 rem;
2986     I32 fail;
2987     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2988     const char *tmps;
2989     const I32 arybase = CopARYBASE_get(PL_curcop);
2990     SV *repl_sv = NULL;
2991     const char *repl = NULL;
2992     STRLEN repl_len;
2993     const int num_args = PL_op->op_private & 7;
2994     bool repl_need_utf8_upgrade = FALSE;
2995     bool repl_is_utf8 = FALSE;
2996
2997     SvTAINTED_off(TARG);                        /* decontaminate */
2998     SvUTF8_off(TARG);                           /* decontaminate */
2999     if (num_args > 2) {
3000         if (num_args > 3) {
3001             repl_sv = POPs;
3002             repl = SvPV_const(repl_sv, repl_len);
3003             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3004         }
3005         len = POPi;
3006     }
3007     pos = POPi;
3008     sv = POPs;
3009     PUTBACK;
3010     if (repl_sv) {
3011         if (repl_is_utf8) {
3012             if (!DO_UTF8(sv))
3013                 sv_utf8_upgrade(sv);
3014         }
3015         else if (DO_UTF8(sv))
3016             repl_need_utf8_upgrade = TRUE;
3017     }
3018     tmps = SvPV_const(sv, curlen);
3019     if (DO_UTF8(sv)) {
3020         utf8_curlen = sv_len_utf8(sv);
3021         if (utf8_curlen == curlen)
3022             utf8_curlen = 0;
3023         else
3024             curlen = utf8_curlen;
3025     }
3026     else
3027         utf8_curlen = 0;
3028
3029     if (pos >= arybase) {
3030         pos -= arybase;
3031         rem = curlen-pos;
3032         fail = rem;
3033         if (num_args > 2) {
3034             if (len < 0) {
3035                 rem += len;
3036                 if (rem < 0)
3037                     rem = 0;
3038             }
3039             else if (rem > len)
3040                      rem = len;
3041         }
3042     }
3043     else {
3044         pos += curlen;
3045         if (num_args < 3)
3046             rem = curlen;
3047         else if (len >= 0) {
3048             rem = pos+len;
3049             if (rem > (I32)curlen)
3050                 rem = curlen;
3051         }
3052         else {
3053             rem = curlen+len;
3054             if (rem < pos)
3055                 rem = pos;
3056         }
3057         if (pos < 0)
3058             pos = 0;
3059         fail = rem;
3060         rem -= pos;
3061     }
3062     if (fail < 0) {
3063         if (lvalue || repl)
3064             Perl_croak(aTHX_ "substr outside of string");
3065         if (ckWARN(WARN_SUBSTR))
3066             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3067         RETPUSHUNDEF;
3068     }
3069     else {
3070         const I32 upos = pos;
3071         const I32 urem = rem;
3072         if (utf8_curlen)
3073             sv_pos_u2b(sv, &pos, &rem);
3074         tmps += pos;
3075         /* we either return a PV or an LV. If the TARG hasn't been used
3076          * before, or is of that type, reuse it; otherwise use a mortal
3077          * instead. Note that LVs can have an extended lifetime, so also
3078          * dont reuse if refcount > 1 (bug #20933) */
3079         if (SvTYPE(TARG) > SVt_NULL) {
3080             if ( (SvTYPE(TARG) == SVt_PVLV)
3081                     ? (!lvalue || SvREFCNT(TARG) > 1)
3082                     : lvalue)
3083             {
3084                 TARG = sv_newmortal();
3085             }
3086         }
3087
3088         sv_setpvn(TARG, tmps, rem);
3089 #ifdef USE_LOCALE_COLLATE
3090         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3091 #endif
3092         if (utf8_curlen)
3093             SvUTF8_on(TARG);
3094         if (repl) {
3095             SV* repl_sv_copy = NULL;
3096
3097             if (repl_need_utf8_upgrade) {
3098                 repl_sv_copy = newSVsv(repl_sv);
3099                 sv_utf8_upgrade(repl_sv_copy);
3100                 repl = SvPV_const(repl_sv_copy, repl_len);
3101                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3102             }
3103             sv_insert(sv, pos, rem, repl, repl_len);
3104             if (repl_is_utf8)
3105                 SvUTF8_on(sv);
3106             if (repl_sv_copy)
3107                 SvREFCNT_dec(repl_sv_copy);
3108         }
3109         else if (lvalue) {              /* it's an lvalue! */
3110             if (!SvGMAGICAL(sv)) {
3111                 if (SvROK(sv)) {
3112                     SvPV_force_nolen(sv);
3113                     if (ckWARN(WARN_SUBSTR))
3114                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3115                                 "Attempt to use reference as lvalue in substr");
3116                 }
3117                 if (isGV_with_GP(sv))
3118                     SvPV_force_nolen(sv);
3119                 else if (SvOK(sv))      /* is it defined ? */
3120                     (void)SvPOK_only_UTF8(sv);
3121                 else
3122                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3123             }
3124
3125             if (SvTYPE(TARG) < SVt_PVLV) {
3126                 sv_upgrade(TARG, SVt_PVLV);
3127                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3128             }
3129
3130             LvTYPE(TARG) = 'x';
3131             if (LvTARG(TARG) != sv) {
3132                 if (LvTARG(TARG))
3133                     SvREFCNT_dec(LvTARG(TARG));
3134                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3135             }
3136             LvTARGOFF(TARG) = upos;
3137             LvTARGLEN(TARG) = urem;
3138         }
3139     }
3140     SPAGAIN;
3141     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3142     RETURN;
3143 }
3144
3145 PP(pp_vec)
3146 {
3147     dVAR; dSP; dTARGET;
3148     register const IV size   = POPi;
3149     register const IV offset = POPi;
3150     register SV * const src = POPs;
3151     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3152
3153     SvTAINTED_off(TARG);                /* decontaminate */
3154     if (lvalue) {                       /* it's an lvalue! */
3155         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3156             TARG = sv_newmortal();
3157         if (SvTYPE(TARG) < SVt_PVLV) {
3158             sv_upgrade(TARG, SVt_PVLV);
3159             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3160         }
3161         LvTYPE(TARG) = 'v';
3162         if (LvTARG(TARG) != src) {
3163             if (LvTARG(TARG))
3164                 SvREFCNT_dec(LvTARG(TARG));
3165             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3166         }
3167         LvTARGOFF(TARG) = offset;
3168         LvTARGLEN(TARG) = size;
3169     }
3170
3171     sv_setuv(TARG, do_vecget(src, offset, size));
3172     PUSHs(TARG);
3173     RETURN;
3174 }
3175
3176 PP(pp_index)
3177 {
3178     dVAR; dSP; dTARGET;
3179     SV *big;
3180     SV *little;
3181     SV *temp = NULL;
3182     STRLEN biglen;
3183     STRLEN llen = 0;
3184     I32 offset;
3185     I32 retval;
3186     const char *big_p;
3187     const char *little_p;
3188     const I32 arybase = CopARYBASE_get(PL_curcop);
3189     bool big_utf8;
3190     bool little_utf8;
3191     const bool is_index = PL_op->op_type == OP_INDEX;
3192
3193     if (MAXARG >= 3) {
3194         /* arybase is in characters, like offset, so combine prior to the
3195            UTF-8 to bytes calculation.  */
3196         offset = POPi - arybase;
3197     }
3198     little = POPs;
3199     big = POPs;
3200     big_p = SvPV_const(big, biglen);
3201     little_p = SvPV_const(little, llen);
3202
3203     big_utf8 = DO_UTF8(big);
3204     little_utf8 = DO_UTF8(little);
3205     if (big_utf8 ^ little_utf8) {
3206         /* One needs to be upgraded.  */
3207         if (little_utf8 && !PL_encoding) {
3208             /* Well, maybe instead we might be able to downgrade the small
3209                string?  */
3210             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3211                                                      &little_utf8);
3212             if (little_utf8) {
3213                 /* If the large string is ISO-8859-1, and it's not possible to
3214                    convert the small string to ISO-8859-1, then there is no
3215                    way that it could be found anywhere by index.  */
3216                 retval = -1;
3217                 goto fail;
3218             }
3219
3220             /* At this point, pv is a malloc()ed string. So donate it to temp
3221                to ensure it will get free()d  */
3222             little = temp = newSV(0);
3223             sv_usepvn(temp, pv, llen);
3224             little_p = SvPVX(little);
3225         } else {
3226             temp = little_utf8
3227                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3228
3229             if (PL_encoding) {
3230                 sv_recode_to_utf8(temp, PL_encoding);
3231             } else {
3232                 sv_utf8_upgrade(temp);
3233             }
3234             if (little_utf8) {
3235                 big = temp;
3236                 big_utf8 = TRUE;
3237                 big_p = SvPV_const(big, biglen);
3238             } else {
3239                 little = temp;
3240                 little_p = SvPV_const(little, llen);
3241             }
3242         }
3243     }
3244     if (SvGAMAGIC(big)) {
3245         /* Life just becomes a lot easier if I use a temporary here.
3246            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3247            will trigger magic and overloading again, as will fbm_instr()
3248         */
3249         big = sv_2mortal(newSVpvn(big_p, biglen));
3250         if (big_utf8)
3251             SvUTF8_on(big);
3252         big_p = SvPVX(big);
3253     }
3254     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3255         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3256            warn on undef, and we've already triggered a warning with the
3257            SvPV_const some lines above. We can't remove that, as we need to
3258            call some SvPV to trigger overloading early and find out if the
3259            string is UTF-8.
3260            This is all getting to messy. The API isn't quite clean enough,
3261            because data access has side effects.
3262         */
3263         little = sv_2mortal(newSVpvn(little_p, llen));
3264         if (little_utf8)
3265             SvUTF8_on(little);
3266         little_p = SvPVX(little);
3267     }
3268
3269     if (MAXARG < 3)
3270         offset = is_index ? 0 : biglen;
3271     else {
3272         if (big_utf8 && offset > 0)
3273             sv_pos_u2b(big, &offset, 0);
3274         if (!is_index)
3275             offset += llen;
3276     }
3277     if (offset < 0)
3278         offset = 0;
3279     else if (offset > (I32)biglen)
3280         offset = biglen;
3281     if (!(little_p = is_index
3282           ? fbm_instr((unsigned char*)big_p + offset,
3283                       (unsigned char*)big_p + biglen, little, 0)
3284           : rninstr(big_p,  big_p  + offset,
3285                     little_p, little_p + llen)))
3286         retval = -1;
3287     else {
3288         retval = little_p - big_p;
3289         if (retval > 0 && big_utf8)
3290             sv_pos_b2u(big, &retval);
3291     }
3292     if (temp)
3293         SvREFCNT_dec(temp);
3294  fail:
3295     PUSHi(retval + arybase);
3296     RETURN;
3297 }
3298
3299 PP(pp_sprintf)
3300 {
3301     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3302     do_sprintf(TARG, SP-MARK, MARK+1);
3303     TAINT_IF(SvTAINTED(TARG));
3304     SP = ORIGMARK;
3305     PUSHTARG;
3306     RETURN;
3307 }
3308
3309 PP(pp_ord)
3310 {
3311     dVAR; dSP; dTARGET;
3312
3313     SV *argsv = POPs;
3314     STRLEN len;
3315     const U8 *s = (U8*)SvPV_const(argsv, len);
3316
3317     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3318         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3319         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3320         argsv = tmpsv;
3321     }
3322
3323     XPUSHu(DO_UTF8(argsv) ?
3324            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3325            (*s & 0xff));
3326
3327     RETURN;
3328 }
3329
3330 PP(pp_chr)
3331 {
3332     dVAR; dSP; dTARGET;
3333     char *tmps;
3334     UV value;
3335
3336     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3337          ||
3338          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3339         if (IN_BYTES) {
3340             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3341         } else {
3342             (void) POPs; /* Ignore the argument value. */
3343             value = UNICODE_REPLACEMENT;
3344         }
3345     } else {
3346         value = POPu;
3347     }
3348
3349     SvUPGRADE(TARG,SVt_PV);
3350
3351     if (value > 255 && !IN_BYTES) {
3352         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3353         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3354         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3355         *tmps = '\0';
3356         (void)SvPOK_only(TARG);
3357         SvUTF8_on(TARG);
3358         XPUSHs(TARG);
3359         RETURN;
3360     }
3361
3362     SvGROW(TARG,2);
3363     SvCUR_set(TARG, 1);
3364     tmps = SvPVX(TARG);
3365     *tmps++ = (char)value;
3366     *tmps = '\0';
3367     (void)SvPOK_only(TARG);
3368
3369     if (PL_encoding && !IN_BYTES) {
3370         sv_recode_to_utf8(TARG, PL_encoding);
3371         tmps = SvPVX(TARG);
3372         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3373             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3374             SvGROW(TARG, 2);
3375             tmps = SvPVX(TARG);
3376             SvCUR_set(TARG, 1);
3377             *tmps++ = (char)value;
3378             *tmps = '\0';
3379             SvUTF8_off(TARG);
3380         }
3381     }
3382
3383     XPUSHs(TARG);
3384     RETURN;
3385 }
3386
3387 PP(pp_crypt)
3388 {
3389 #ifdef HAS_CRYPT
3390     dVAR; dSP; dTARGET;
3391     dPOPTOPssrl;
3392     STRLEN len;
3393     const char *tmps = SvPV_const(left, len);
3394
3395     if (DO_UTF8(left)) {
3396          /* If Unicode, try to downgrade.
3397           * If not possible, croak.
3398           * Yes, we made this up.  */
3399          SV* const tsv = sv_2mortal(newSVsv(left));
3400
3401          SvUTF8_on(tsv);
3402          sv_utf8_downgrade(tsv, FALSE);
3403          tmps = SvPV_const(tsv, len);
3404     }
3405 #   ifdef USE_ITHREADS
3406 #     ifdef HAS_CRYPT_R
3407     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3408       /* This should be threadsafe because in ithreads there is only
3409        * one thread per interpreter.  If this would not be true,
3410        * we would need a mutex to protect this malloc. */
3411         PL_reentrant_buffer->_crypt_struct_buffer =
3412           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3413 #if defined(__GLIBC__) || defined(__EMX__)
3414         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3415             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3416             /* work around glibc-2.2.5 bug */
3417             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3418         }
3419 #endif
3420     }
3421 #     endif /* HAS_CRYPT_R */
3422 #   endif /* USE_ITHREADS */
3423 #   ifdef FCRYPT
3424     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3425 #   else
3426     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3427 #   endif
3428     SETs(TARG);
3429     RETURN;
3430 #else
3431     DIE(aTHX_
3432       "The crypt() function is unimplemented due to excessive paranoia.");
3433 #endif
3434 }
3435
3436 PP(pp_ucfirst)
3437 {
3438     dVAR;
3439     dSP;
3440     SV *source = TOPs;
3441     STRLEN slen;
3442     STRLEN need;
3443     SV *dest;
3444     bool inplace = TRUE;
3445     bool doing_utf8;
3446     const int op_type = PL_op->op_type;
3447     const U8 *s;
3448     U8 *d;
3449     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3450     STRLEN ulen;
3451     STRLEN tculen;
3452
3453     SvGETMAGIC(source);
3454     if (SvOK(source)) {
3455         s = (const U8*)SvPV_nomg_const(source, slen);
3456     } else {
3457         s = (const U8*)"";
3458         slen = 0;
3459     }
3460
3461     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3462         doing_utf8 = TRUE;
3463         utf8_to_uvchr(s, &ulen);
3464         if (op_type == OP_UCFIRST) {
3465             toTITLE_utf8(s, tmpbuf, &tculen);
3466         } else {
3467             toLOWER_utf8(s, tmpbuf, &tculen);
3468         }
3469         /* If the two differ, we definately cannot do inplace.  */
3470         inplace = (ulen == tculen);
3471         need = slen + 1 - ulen + tculen;
3472     } else {
3473         doing_utf8 = FALSE;
3474         need = slen + 1;
3475     }
3476
3477     if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3478         /* We can convert in place.  */
3479
3480         dest = source;
3481         s = d = (U8*)SvPV_force_nomg(source, slen);
3482     } else {
3483         dTARGET;
3484
3485         dest = TARG;
3486
3487         SvUPGRADE(dest, SVt_PV);
3488         d = (U8*)SvGROW(dest, need);
3489         (void)SvPOK_only(dest);
3490
3491         SETs(dest);
3492
3493         inplace = FALSE;
3494     }
3495
3496     if (doing_utf8) {
3497         if(!inplace) {
3498             /* slen is the byte length of the whole SV.
3499              * ulen is the byte length of the original Unicode character
3500              * stored as UTF-8 at s.
3501              * tculen is the byte length of the freshly titlecased (or
3502              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3503              * We first set the result to be the titlecased (/lowercased)
3504              * character, and then append the rest of the SV data. */
3505             sv_setpvn(dest, (char*)tmpbuf, tculen);
3506             if (slen > ulen)
3507                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3508             SvUTF8_on(dest);
3509         }
3510         else {
3511             Copy(tmpbuf, d, tculen, U8);
3512             SvCUR_set(dest, need - 1);
3513         }
3514     }
3515     else {
3516         if (*s) {
3517             if (IN_LOCALE_RUNTIME) {
3518                 TAINT;
3519                 SvTAINTED_on(dest);
3520                 *d = (op_type == OP_UCFIRST)
3521                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3522             }
3523             else
3524                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3525         } else {
3526             /* See bug #39028  */
3527             *d = *s;
3528         }
3529
3530         if (SvUTF8(source))
3531             SvUTF8_on(dest);
3532
3533         if (!inplace) {
3534             /* This will copy the trailing NUL  */
3535             Copy(s + 1, d + 1, slen, U8);
3536             SvCUR_set(dest, need - 1);
3537         }
3538     }
3539     SvSETMAGIC(dest);
3540     RETURN;
3541 }
3542
3543 /* There's so much setup/teardown code common between uc and lc, I wonder if
3544    it would be worth merging the two, and just having a switch outside each
3545    of the three tight loops.  */
3546 PP(pp_uc)
3547 {
3548     dVAR;
3549     dSP;
3550     SV *source = TOPs;
3551     STRLEN len;
3552     STRLEN min;
3553     SV *dest;
3554     const U8 *s;
3555     U8 *d;
3556
3557     SvGETMAGIC(source);
3558
3559     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3560         && !DO_UTF8(source)) {
3561         /* We can convert in place.  */
3562
3563         dest = source;
3564         s = d = (U8*)SvPV_force_nomg(source, len);
3565         min = len + 1;
3566     } else {
3567         dTARGET;
3568
3569         dest = TARG;
3570
3571         /* The old implementation would copy source into TARG at this point.
3572            This had the side effect that if source was undef, TARG was now
3573            an undefined SV with PADTMP set, and they don't warn inside
3574            sv_2pv_flags(). However, we're now getting the PV direct from
3575            source, which doesn't have PADTMP set, so it would warn. Hence the
3576            little games.  */
3577
3578         if (SvOK(source)) {
3579             s = (const U8*)SvPV_nomg_const(source, len);
3580         } else {
3581             s = (const U8*)"";
3582             len = 0;
3583         }
3584         min = len + 1;
3585
3586         SvUPGRADE(dest, SVt_PV);
3587         d = (U8*)SvGROW(dest, min);
3588         (void)SvPOK_only(dest);
3589
3590         SETs(dest);
3591     }
3592
3593     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3594        to check DO_UTF8 again here.  */
3595
3596     if (DO_UTF8(source)) {
3597         const U8 *const send = s + len;
3598         U8 tmpbuf[UTF8_MAXBYTES+1];
3599
3600         while (s < send) {
3601             const STRLEN u = UTF8SKIP(s);
3602             STRLEN ulen;
3603
3604             toUPPER_utf8(s, tmpbuf, &ulen);
3605             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3606                 /* If the eventually required minimum size outgrows
3607                  * the available space, we need to grow. */
3608                 const UV o = d - (U8*)SvPVX_const(dest);
3609
3610                 /* If someone uppercases one million U+03B0s we SvGROW() one
3611                  * million times.  Or we could try guessing how much to
3612                  allocate without allocating too much.  Such is life. */
3613                 SvGROW(dest, min);
3614                 d = (U8*)SvPVX(dest) + o;
3615             }
3616             Copy(tmpbuf, d, ulen, U8);
3617             d += ulen;
3618             s += u;
3619         }
3620         SvUTF8_on(dest);
3621         *d = '\0';
3622         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3623     } else {
3624         if (len) {
3625             const U8 *const send = s + len;
3626             if (IN_LOCALE_RUNTIME) {
3627                 TAINT;
3628                 SvTAINTED_on(dest);
3629                 for (; s < send; d++, s++)
3630                     *d = toUPPER_LC(*s);
3631             }
3632             else {
3633                 for (; s < send; d++, s++)
3634                     *d = toUPPER(*s);
3635             }
3636         }
3637         if (source != dest) {
3638             *d = '\0';
3639             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3640         }
3641     }
3642     SvSETMAGIC(dest);
3643     RETURN;
3644 }
3645
3646 PP(pp_lc)
3647 {
3648     dVAR;
3649     dSP;
3650     SV *source = TOPs;
3651     STRLEN len;
3652     STRLEN min;
3653     SV *dest;
3654     const U8 *s;
3655     U8 *d;
3656
3657     SvGETMAGIC(source);
3658
3659     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3660         && !DO_UTF8(source)) {
3661         /* We can convert in place.  */
3662
3663         dest = source;
3664         s = d = (U8*)SvPV_force_nomg(source, len);
3665         min = len + 1;
3666     } else {
3667         dTARGET;
3668
3669         dest = TARG;
3670
3671         /* The old implementation would copy source into TARG at this point.
3672            This had the side effect that if source was undef, TARG was now
3673            an undefined SV with PADTMP set, and they don't warn inside
3674            sv_2pv_flags(). However, we're now getting the PV direct from
3675            source, which doesn't have PADTMP set, so it would warn. Hence the
3676            little games.  */
3677
3678         if (SvOK(source)) {
3679             s = (const U8*)SvPV_nomg_const(source, len);
3680         } else {
3681             s = (const U8*)"";
3682             len = 0;
3683         }
3684         min = len + 1;
3685
3686         SvUPGRADE(dest, SVt_PV);
3687         d = (U8*)SvGROW(dest, min);
3688         (void)SvPOK_only(dest);
3689
3690         SETs(dest);
3691     }
3692
3693     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3694        to check DO_UTF8 again here.  */
3695
3696     if (DO_UTF8(source)) {
3697         const U8 *const send = s + len;
3698         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3699
3700         while (s < send) {
3701             const STRLEN u = UTF8SKIP(s);
3702             STRLEN ulen;
3703             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3704
3705 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3706             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3707                 NOOP;
3708                 /*
3709                  * Now if the sigma is NOT followed by
3710                  * /$ignorable_sequence$cased_letter/;
3711                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3712                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3713                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3714                  * then it should be mapped to 0x03C2,
3715                  * (GREEK SMALL LETTER FINAL SIGMA),
3716                  * instead of staying 0x03A3.
3717                  * "should be": in other words, this is not implemented yet.
3718                  * See lib/unicore/SpecialCasing.txt.
3719                  */
3720             }
3721             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3722                 /* If the eventually required minimum size outgrows
3723                  * the available space, we need to grow. */
3724                 const UV o = d - (U8*)SvPVX_const(dest);
3725
3726                 /* If someone lowercases one million U+0130s we SvGROW() one
3727                  * million times.  Or we could try guessing how much to
3728                  allocate without allocating too much.  Such is life. */
3729                 SvGROW(dest, min);
3730                 d = (U8*)SvPVX(dest) + o;
3731             }
3732             Copy(tmpbuf, d, ulen, U8);
3733             d += ulen;
3734             s += u;
3735         }
3736         SvUTF8_on(dest);
3737         *d = '\0';
3738         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3739     } else {
3740         if (len) {
3741             const U8 *const send = s + len;
3742             if (IN_LOCALE_RUNTIME) {
3743                 TAINT;
3744                 SvTAINTED_on(dest);
3745                 for (; s < send; d++, s++)
3746                     *d = toLOWER_LC(*s);
3747             }
3748             else {
3749                 for (; s < send; d++, s++)
3750                     *d = toLOWER(*s);
3751             }
3752         }
3753         if (source != dest) {
3754             *d = '\0';
3755             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3756         }
3757     }
3758     SvSETMAGIC(dest);
3759     RETURN;
3760 }
3761
3762 PP(pp_quotemeta)
3763 {
3764     dVAR; dSP; dTARGET;
3765     SV * const sv = TOPs;
3766     STRLEN len;
3767     register const char *s = SvPV_const(sv,len);
3768
3769     SvUTF8_off(TARG);                           /* decontaminate */
3770     if (len) {
3771         register char *d;
3772         SvUPGRADE(TARG, SVt_PV);
3773         SvGROW(TARG, (len * 2) + 1);
3774         d = SvPVX(TARG);
3775         if (DO_UTF8(sv)) {
3776             while (len) {
3777                 if (UTF8_IS_CONTINUED(*s)) {
3778                     STRLEN ulen = UTF8SKIP(s);
3779                     if (ulen > len)
3780                         ulen = len;
3781                     len -= ulen;
3782                     while (ulen--)
3783                         *d++ = *s++;
3784                 }
3785                 else {
3786                     if (!isALNUM(*s))
3787                         *d++ = '\\';
3788                     *d++ = *s++;
3789                     len--;
3790                 }
3791             }
3792             SvUTF8_on(TARG);
3793         }
3794         else {
3795             while (len--) {
3796                 if (!isALNUM(*s))
3797                     *d++ = '\\';
3798                 *d++ = *s++;
3799             }
3800         }
3801         *d = '\0';
3802         SvCUR_set(TARG, d - SvPVX_const(TARG));
3803         (void)SvPOK_only_UTF8(TARG);
3804     }
3805     else
3806         sv_setpvn(TARG, s, len);
3807     SETs(TARG);
3808     if (SvSMAGICAL(TARG))
3809         mg_set(TARG);
3810     RETURN;
3811 }
3812
3813 /* Arrays. */
3814
3815 PP(pp_aslice)
3816 {
3817     dVAR; dSP; dMARK; dORIGMARK;
3818     register AV* const av = (AV*)POPs;
3819     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3820
3821     if (SvTYPE(av) == SVt_PVAV) {
3822         const I32 arybase = CopARYBASE_get(PL_curcop);
3823         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3824             register SV **svp;
3825             I32 max = -1;
3826             for (svp = MARK + 1; svp <= SP; svp++) {
3827                 const I32 elem = SvIVx(*svp);
3828                 if (elem > max)
3829                     max = elem;
3830             }
3831             if (max > AvMAX(av))
3832                 av_extend(av, max);
3833         }
3834         while (++MARK <= SP) {
3835             register SV **svp;
3836             I32 elem = SvIVx(*MARK);
3837
3838             if (elem > 0)
3839                 elem -= arybase;
3840             svp = av_fetch(av, elem, lval);
3841             if (lval) {
3842                 if (!svp || *svp == &PL_sv_undef)
3843                     DIE(aTHX_ PL_no_aelem, elem);
3844                 if (PL_op->op_private & OPpLVAL_INTRO)
3845                     save_aelem(av, elem, svp);
3846             }
3847             *MARK = svp ? *svp : &PL_sv_undef;
3848         }
3849     }
3850     if (GIMME != G_ARRAY) {
3851         MARK = ORIGMARK;
3852         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3853         SP = MARK;
3854     }
3855     RETURN;
3856 }
3857
3858 /* Associative arrays. */
3859
3860 PP(pp_each)
3861 {
3862     dVAR;
3863     dSP;
3864     HV * const hash = (HV*)POPs;
3865     HE *entry;
3866     const I32 gimme = GIMME_V;
3867
3868     PUTBACK;
3869     /* might clobber stack_sp */
3870     entry = hv_iternext(hash);
3871     SPAGAIN;
3872
3873     EXTEND(SP, 2);
3874     if (entry) {
3875         SV* const sv = hv_iterkeysv(entry);
3876         PUSHs(sv);      /* won't clobber stack_sp */
3877         if (gimme == G_ARRAY) {
3878             SV *val;
3879             PUTBACK;
3880             /* might clobber stack_sp */
3881             val = hv_iterval(hash, entry);
3882             SPAGAIN;
3883             PUSHs(val);
3884         }
3885     }
3886     else if (gimme == G_SCALAR)
3887         RETPUSHUNDEF;
3888
3889     RETURN;
3890 }
3891
3892 PP(pp_delete)
3893 {
3894     dVAR;
3895     dSP;
3896     const I32 gimme = GIMME_V;
3897     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3898
3899     if (PL_op->op_private & OPpSLICE) {
3900         dMARK; dORIGMARK;
3901         HV * const hv = (HV*)POPs;
3902         const U32 hvtype = SvTYPE(hv);
3903         if (hvtype == SVt_PVHV) {                       /* hash element */
3904             while (++MARK <= SP) {
3905                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3906                 *MARK = sv ? sv : &PL_sv_undef;
3907             }
3908         }
3909         else if (hvtype == SVt_PVAV) {                  /* array element */
3910             if (PL_op->op_flags & OPf_SPECIAL) {
3911                 while (++MARK <= SP) {
3912                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3913                     *MARK = sv ? sv : &PL_sv_undef;
3914                 }
3915             }
3916         }
3917         else
3918             DIE(aTHX_ "Not a HASH reference");
3919         if (discard)
3920             SP = ORIGMARK;
3921         else if (gimme == G_SCALAR) {
3922             MARK = ORIGMARK;
3923             if (SP > MARK)
3924                 *++MARK = *SP;
3925             else
3926                 *++MARK = &PL_sv_undef;
3927             SP = MARK;
3928         }
3929     }
3930     else {
3931         SV *keysv = POPs;
3932         HV * const hv = (HV*)POPs;
3933         SV *sv;
3934         if (SvTYPE(hv) == SVt_PVHV)
3935             sv = hv_delete_ent(hv, keysv, discard, 0);
3936         else if (SvTYPE(hv) == SVt_PVAV) {
3937             if (PL_op->op_flags & OPf_SPECIAL)
3938                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3939             else
3940                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3941         }
3942         else
3943             DIE(aTHX_ "Not a HASH reference");
3944         if (!sv)
3945             sv = &PL_sv_undef;
3946         if (!discard)
3947             PUSHs(sv);
3948     }
3949     RETURN;
3950 }
3951
3952 PP(pp_exists)
3953 {
3954     dVAR;
3955     dSP;
3956     SV *tmpsv;
3957     HV *hv;
3958
3959     if (PL_op->op_private & OPpEXISTS_SUB) {
3960         GV *gv;
3961         SV * const sv = POPs;
3962         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3963         if (cv)
3964             RETPUSHYES;
3965         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3966             RETPUSHYES;
3967         RETPUSHNO;
3968     }
3969     tmpsv = POPs;
3970     hv = (HV*)POPs;
3971     if (SvTYPE(hv) == SVt_PVHV) {
3972         if (hv_exists_ent(hv, tmpsv, 0))
3973             RETPUSHYES;
3974     }
3975     else if (SvTYPE(hv) == SVt_PVAV) {
3976         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3977             if (av_exists((AV*)hv, SvIV(tmpsv)))
3978                 RETPUSHYES;
3979         }
3980     }
3981     else {
3982         DIE(aTHX_ "Not a HASH reference");
3983     }
3984     RETPUSHNO;
3985 }
3986
3987 PP(pp_hslice)
3988 {
3989     dVAR; dSP; dMARK; dORIGMARK;
3990     register HV * const hv = (HV*)POPs;
3991     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3992     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3993     bool other_magic = FALSE;
3994
3995     if (localizing) {
3996         MAGIC *mg;
3997         HV *stash;
3998
3999         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4000             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4001              /* Try to preserve the existenceness of a tied hash
4002               * element by using EXISTS and DELETE if possible.
4003               * Fallback to FETCH and STORE otherwise */
4004              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4005              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4006              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4007     }
4008
4009     while (++MARK <= SP) {
4010         SV * const keysv = *MARK;
4011         SV **svp;
4012         HE *he;
4013         bool preeminent = FALSE;
4014
4015         if (localizing) {
4016             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4017                 hv_exists_ent(hv, keysv, 0);
4018         }
4019
4020         he = hv_fetch_ent(hv, keysv, lval, 0);
4021         svp = he ? &HeVAL(he) : 0;
4022
4023         if (lval) {
4024             if (!svp || *svp == &PL_sv_undef) {
4025                 DIE(aTHX_ PL_no_helem_sv, keysv);
4026             }
4027             if (localizing) {
4028                 if (HvNAME_get(hv) && isGV(*svp))
4029                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4030                 else {
4031                     if (preeminent)
4032                         save_helem(hv, keysv, svp);
4033                     else {
4034                         STRLEN keylen;
4035                         const char * const key = SvPV_const(keysv, keylen);
4036                         SAVEDELETE(hv, savepvn(key,keylen),
4037                                    SvUTF8(keysv) ? -keylen : keylen);
4038                     }
4039                 }
4040             }
4041         }
4042         *MARK = svp ? *svp : &PL_sv_undef;
4043     }
4044     if (GIMME != G_ARRAY) {
4045         MARK = ORIGMARK;
4046         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4047         SP = MARK;
4048     }
4049     RETURN;
4050 }
4051
4052 /* List operators. */
4053
4054 PP(pp_list)
4055 {
4056     dVAR; dSP; dMARK;
4057     if (GIMME != G_ARRAY) {
4058         if (++MARK <= SP)
4059             *MARK = *SP;                /* unwanted list, return last item */
4060         else
4061             *MARK = &PL_sv_undef;
4062         SP = MARK;
4063     }
4064     RETURN;
4065 }
4066
4067 PP(pp_lslice)
4068 {
4069     dVAR;
4070     dSP;
4071     SV ** const lastrelem = PL_stack_sp;
4072     SV ** const lastlelem = PL_stack_base + POPMARK;
4073     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4074     register SV ** const firstrelem = lastlelem + 1;
4075     const I32 arybase = CopARYBASE_get(PL_curcop);
4076     I32 is_something_there = PL_op->op_flags & OPf_MOD;
4077
4078     register const I32 max = lastrelem - lastlelem;
4079     register SV **lelem;
4080
4081     if (GIMME != G_ARRAY) {
4082         I32 ix = SvIVx(*lastlelem);
4083         if (ix < 0)
4084             ix += max;
4085         else
4086             ix -= arybase;
4087         if (ix < 0 || ix >= max)
4088             *firstlelem = &PL_sv_undef;
4089         else
4090             *firstlelem = firstrelem[ix];
4091         SP = firstlelem;
4092         RETURN;
4093     }
4094
4095     if (max == 0) {
4096         SP = firstlelem - 1;
4097         RETURN;
4098     }
4099
4100     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4101         I32 ix = SvIVx(*lelem);
4102         if (ix < 0)
4103             ix += max;
4104         else
4105             ix -= arybase;
4106         if (ix < 0 || ix >= max)
4107             *lelem = &PL_sv_undef;
4108         else {
4109             is_something_there = TRUE;
4110             if (!(*lelem = firstrelem[ix]))
4111                 *lelem = &PL_sv_undef;
4112         }
4113     }
4114     if (is_something_there)
4115         SP = lastlelem;
4116     else
4117         SP = firstlelem - 1;
4118     RETURN;
4119 }
4120
4121 PP(pp_anonlist)
4122 {
4123     dVAR; dSP; dMARK; dORIGMARK;
4124     const I32 items = SP - MARK;
4125     SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4126     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4127     XPUSHs(av);
4128     RETURN;
4129 }
4130
4131 PP(pp_anonhash)
4132 {
4133     dVAR; dSP; dMARK; dORIGMARK;
4134     HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4135
4136     while (MARK < SP) {
4137         SV * const key = *++MARK;
4138         SV * const val = newSV(0);
4139         if (MARK < SP)
4140             sv_setsv(val, *++MARK);
4141         else if (ckWARN(WARN_MISC))
4142             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4143         (void)hv_store_ent(hv,key,val,0);
4144     }
4145     SP = ORIGMARK;
4146     XPUSHs((SV*)hv);
4147     RETURN;
4148 }
4149
4150 PP(pp_splice)
4151 {
4152     dVAR; dSP; dMARK; dORIGMARK;
4153     register AV *ary = (AV*)*++MARK;
4154     register SV **src;
4155     register SV **dst;
4156     register I32 i;
4157     register I32 offset;
4158     register I32 length;
4159     I32 newlen;
4160     I32 after;
4161     I32 diff;
4162     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4163
4164     if (mg) {
4165         *MARK-- = SvTIED_obj((SV*)ary, mg);
4166         PUSHMARK(MARK);
4167         PUTBACK;
4168         ENTER;
4169         call_method("SPLICE",GIMME_V);
4170         LEAVE;
4171         SPAGAIN;
4172         RETURN;
4173     }
4174
4175     SP++;
4176
4177     if (++MARK < SP) {
4178         offset = i = SvIVx(*MARK);
4179         if (offset < 0)
4180             offset += AvFILLp(ary) + 1;
4181         else
4182             offset -= CopARYBASE_get(PL_curcop);
4183         if (offset < 0)
4184             DIE(aTHX_ PL_no_aelem, i);
4185         if (++MARK < SP) {
4186             length = SvIVx(*MARK++);
4187             if (length < 0) {
4188                 length += AvFILLp(ary) - offset + 1;
4189                 if (length < 0)
4190                     length = 0;
4191             }
4192         }
4193         else
4194             length = AvMAX(ary) + 1;            /* close enough to infinity */
4195     }
4196     else {
4197         offset = 0;
4198         length = AvMAX(ary) + 1;
4199     }
4200     if (offset > AvFILLp(ary) + 1) {
4201         if (ckWARN(WARN_MISC))
4202             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4203         offset = AvFILLp(ary) + 1;
4204     }
4205     after = AvFILLp(ary) + 1 - (offset + length);
4206     if (after < 0) {                            /* not that much array */
4207         length += after;                        /* offset+length now in array */
4208         after = 0;
4209         if (!AvALLOC(ary))
4210             av_extend(ary, 0);
4211     }
4212
4213     /* At this point, MARK .. SP-1 is our new LIST */
4214
4215     newlen = SP - MARK;
4216     diff = newlen - length;
4217     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4218         av_reify(ary);
4219
4220     /* make new elements SVs now: avoid problems if they're from the array */
4221     for (dst = MARK, i = newlen; i; i--) {
4222         SV * const h = *dst;
4223         *dst++ = newSVsv(h);
4224     }
4225
4226     if (diff < 0) {                             /* shrinking the area */
4227         SV **tmparyval = NULL;
4228         if (newlen) {
4229             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4230             Copy(MARK, tmparyval, newlen, SV*);
4231         }
4232
4233         MARK = ORIGMARK + 1;
4234         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4235             MEXTEND(MARK, length);
4236             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4237             if (AvREAL(ary)) {
4238                 EXTEND_MORTAL(length);
4239                 for (i = length, dst = MARK; i; i--) {
4240                     sv_2mortal(*dst);   /* free them eventualy */
4241                     dst++;
4242                 }
4243             }
4244             MARK += length - 1;
4245         }
4246         else {
4247             *MARK = AvARRAY(ary)[offset+length-1];
4248             if (AvREAL(ary)) {
4249                 sv_2mortal(*MARK);
4250                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4251                     SvREFCNT_dec(*dst++);       /* free them now */
4252             }
4253         }
4254         AvFILLp(ary) += diff;
4255
4256         /* pull up or down? */
4257
4258         if (offset < after) {                   /* easier to pull up */
4259             if (offset) {                       /* esp. if nothing to pull */
4260                 src = &AvARRAY(ary)[offset-1];
4261                 dst = src - diff;               /* diff is negative */
4262                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4263                     *dst-- = *src--;
4264             }
4265             dst = AvARRAY(ary);
4266             SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4267             AvMAX(ary) += diff;
4268         }
4269         else {
4270             if (after) {                        /* anything to pull down? */
4271                 src = AvARRAY(ary) + offset + length;
4272                 dst = src + diff;               /* diff is negative */
4273                 Move(src, dst, after, SV*);
4274             }
4275             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4276                                                 /* avoid later double free */
4277         }
4278         i = -diff;
4279         while (i)
4280             dst[--i] = &PL_sv_undef;
4281
4282         if (newlen) {
4283             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4284             Safefree(tmparyval);
4285         }
4286     }
4287     else {                                      /* no, expanding (or same) */
4288         SV** tmparyval = NULL;
4289         if (length) {
4290             Newx(tmparyval, length, SV*);       /* so remember deletion */
4291             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4292         }
4293
4294         if (diff > 0) {                         /* expanding */
4295             /* push up or down? */
4296             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4297                 if (offset) {
4298                     src = AvARRAY(ary);
4299                     dst = src - diff;
4300                     Move(src, dst, offset, SV*);
4301                 }
4302                 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4303                 AvMAX(ary) += diff;
4304                 AvFILLp(ary) += diff;
4305             }
4306             else {
4307                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4308                     av_extend(ary, AvFILLp(ary) + diff);
4309                 AvFILLp(ary) += diff;
4310
4311                 if (after) {
4312                     dst = AvARRAY(ary) + AvFILLp(ary);
4313                     src = dst - diff;
4314                     for (i = after; i; i--) {
4315                         *dst-- = *src--;
4316                     }
4317                 }
4318             }
4319         }
4320
4321         if (newlen) {
4322             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4323         }
4324
4325         MARK = ORIGMARK + 1;
4326         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4327             if (length) {
4328                 Copy(tmparyval, MARK, length, SV*);
4329                 if (AvREAL(ary)) {
4330                     EXTEND_MORTAL(length);
4331                     for (i = length, dst = MARK; i; i--) {
4332                         sv_2mortal(*dst);       /* free them eventualy */
4333                         dst++;
4334                     }
4335                 }
4336             }
4337             MARK += length - 1;
4338         }
4339         else if (length--) {
4340             *MARK = tmparyval[length];
4341             if (AvREAL(ary)) {
4342                 sv_2mortal(*MARK);
4343                 while (length-- > 0)
4344                     SvREFCNT_dec(tmparyval[length]);
4345             }
4346         }
4347         else
4348             *MARK = &PL_sv_undef;
4349         Safefree(tmparyval);
4350     }
4351     SP = MARK;
4352     RETURN;
4353 }
4354
4355 PP(pp_push)
4356 {
4357     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4358     register AV * const ary = (AV*)*++MARK;
4359     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4360
4361     if (mg) {
4362         *MARK-- = SvTIED_obj((SV*)ary, mg);
4363         PUSHMARK(MARK);
4364         PUTBACK;
4365         ENTER;
4366         call_method("PUSH",G_SCALAR|G_DISCARD);
4367         LEAVE;
4368         SPAGAIN;
4369         SP = ORIGMARK;
4370         PUSHi( AvFILL(ary) + 1 );
4371     }
4372     else {
4373         for (++MARK; MARK <= SP; MARK++) {
4374             SV * const sv = newSV(0);
4375             if (*MARK)
4376                 sv_setsv(sv, *MARK);
4377             av_store(ary, AvFILLp(ary)+1, sv);
4378         }
4379         SP = ORIGMARK;
4380         PUSHi( AvFILLp(ary) + 1 );
4381     }
4382     RETURN;
4383 }
4384
4385 PP(pp_shift)
4386 {
4387     dVAR;
4388     dSP;
4389     AV * const av = (AV*)POPs;
4390     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4391     EXTEND(SP, 1);
4392     assert (sv);
4393     if (AvREAL(av))
4394         (void)sv_2mortal(sv);
4395     PUSHs(sv);
4396     RETURN;
4397 }
4398
4399 PP(pp_unshift)
4400 {
4401     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4402     register AV *ary = (AV*)*++MARK;
4403     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4404
4405     if (mg) {
4406         *MARK-- = SvTIED_obj((SV*)ary, mg);
4407         PUSHMARK(MARK);
4408         PUTBACK;
4409         ENTER;
4410         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4411         LEAVE;
4412         SPAGAIN;
4413     }
4414     else {
4415         register I32 i = 0;
4416         av_unshift(ary, SP - MARK);
4417         while (MARK < SP) {
4418             SV * const sv = newSVsv(*++MARK);
4419             (void)av_store(ary, i++, sv);
4420         }
4421     }
4422     SP = ORIGMARK;
4423     PUSHi( AvFILL(ary) + 1 );
4424     RETURN;
4425 }
4426
4427 PP(pp_reverse)
4428 {
4429     dVAR; dSP; dMARK;
4430     SV ** const oldsp = SP;
4431
4432     if (GIMME == G_ARRAY) {
4433         MARK++;
4434         while (MARK < SP) {
4435             register SV * const tmp = *MARK;
4436             *MARK++ = *SP;
4437             *SP-- = tmp;
4438         }
4439         /* safe as long as stack cannot get extended in the above */
4440         SP = oldsp;
4441     }
4442     else {
4443         register char *up;
4444         register char *down;
4445         register I32 tmp;
4446         dTARGET;
4447         STRLEN len;
4448         PADOFFSET padoff_du;
4449
4450         SvUTF8_off(TARG);                               /* decontaminate */
4451         if (SP - MARK > 1)
4452             do_join(TARG, &PL_sv_no, MARK, SP);
4453         else
4454             sv_setsv(TARG, (SP > MARK)
4455                     ? *SP
4456                     : (padoff_du = find_rundefsvoffset(),
4457                         (padoff_du == NOT_IN_PAD
4458                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4459                         ? DEFSV : PAD_SVl(padoff_du)));
4460         up = SvPV_force(TARG, len);
4461         if (len > 1) {
4462             if (DO_UTF8(TARG)) {        /* first reverse each character */
4463                 U8* s = (U8*)SvPVX(TARG);
4464                 const U8* send = (U8*)(s + len);
4465                 while (s < send) {
4466                     if (UTF8_IS_INVARIANT(*s)) {
4467                         s++;
4468                         continue;
4469                     }
4470                     else {
4471                         if (!utf8_to_uvchr(s, 0))
4472                             break;
4473                         up = (char*)s;
4474                         s += UTF8SKIP(s);
4475                         down = (char*)(s - 1);
4476                         /* reverse this character */
4477                         while (down > up) {
4478                             tmp = *up;
4479                             *up++ = *down;
4480                             *down-- = (char)tmp;
4481                         }
4482                     }
4483                 }
4484                 up = SvPVX(TARG);
4485             }
4486             down = SvPVX(TARG) + len - 1;
4487             while (down > up) {
4488                 tmp = *up;
4489                 *up++ = *down;
4490                 *down-- = (char)tmp;
4491             }
4492             (void)SvPOK_only_UTF8(TARG);
4493         }
4494         SP = MARK + 1;
4495         SETTARG;
4496     }
4497     RETURN;
4498 }
4499
4500 PP(pp_split)
4501 {
4502     dVAR; dSP; dTARG;
4503     AV *ary;
4504     register IV limit = POPi;                   /* note, negative is forever */
4505     SV * const sv = POPs;
4506     STRLEN len;
4507     register const char *s = SvPV_const(sv, len);
4508     const bool do_utf8 = DO_UTF8(sv);
4509     const char *strend = s + len;
4510     register PMOP *pm;
4511     register REGEXP *rx;
4512     register SV *dstr;
4513     register const char *m;
4514     I32 iters = 0;
4515     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4516     I32 maxiters = slen + 10;
4517     const char *orig;
4518     const I32 origlimit = limit;
4519     I32 realarray = 0;
4520     I32 base;
4521     const I32 gimme = GIMME_V;
4522     const I32 oldsave = PL_savestack_ix;
4523     I32 make_mortal = 1;
4524     bool multiline = 0;
4525     MAGIC *mg = NULL;
4526
4527 #ifdef DEBUGGING
4528     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4529 #else
4530     pm = (PMOP*)POPs;
4531 #endif
4532     if (!pm || !s)
4533         DIE(aTHX_ "panic: pp_split");
4534     rx = PM_GETRE(pm);
4535
4536     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4537              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4538
4539     RX_MATCH_UTF8_set(rx, do_utf8);
4540
4541     if (pm->op_pmreplroot) {
4542 #ifdef USE_ITHREADS
4543         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4544 #else
4545         ary = GvAVn((GV*)pm->op_pmreplroot);
4546 #endif
4547     }
4548     else if (gimme != G_ARRAY)
4549         ary = GvAVn(PL_defgv);
4550     else
4551         ary = NULL;
4552     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4553         realarray = 1;
4554         PUTBACK;
4555         av_extend(ary,0);
4556         av_clear(ary);
4557         SPAGAIN;
4558         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4559             PUSHMARK(SP);
4560             XPUSHs(SvTIED_obj((SV*)ary, mg));
4561         }
4562         else {
4563             if (!AvREAL(ary)) {
4564                 I32 i;
4565                 AvREAL_on(ary);
4566                 AvREIFY_off(ary);
4567                 for (i = AvFILLp(ary); i >= 0; i--)
4568                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4569             }
4570             /* temporarily switch stacks */
4571             SAVESWITCHSTACK(PL_curstack, ary);
4572             make_mortal = 0;
4573         }
4574     }
4575     base = SP - PL_stack_base;
4576     orig = s;
4577     if (pm->op_pmflags & PMf_SKIPWHITE) {
4578         if (pm->op_pmflags & PMf_LOCALE) {
4579             while (isSPACE_LC(*s))
4580                 s++;
4581         }
4582         else {
4583             while (isSPACE(*s))
4584                 s++;
4585         }
4586     }
4587     if (pm->op_pmflags & PMf_MULTILINE) {
4588         multiline = 1;
4589     }
4590
4591     if (!limit)
4592         limit = maxiters + 2;
4593     if (pm->op_pmflags & PMf_WHITE) {
4594         while (--limit) {
4595             m = s;
4596             while (m < strend &&
4597                    !((pm->op_pmflags & PMf_LOCALE)
4598                      ? isSPACE_LC(*m) : isSPACE(*m)))
4599                 ++m;
4600             if (m >= strend)
4601                 break;
4602
4603             dstr = newSVpvn(s, m-s);
4604             if (make_mortal)
4605                 sv_2mortal(dstr);
4606             if (do_utf8)
4607                 (void)SvUTF8_on(dstr);
4608             XPUSHs(dstr);
4609
4610             s = m + 1;
4611             while (s < strend &&
4612                    ((pm->op_pmflags & PMf_LOCALE)
4613                     ? isSPACE_LC(*s) : isSPACE(*s)))
4614                 ++s;
4615         }
4616     }
4617     else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4618         while (--limit) {
4619             for (m = s; m < strend && *m != '\n'; m++)
4620                 ;
4621             m++;
4622             if (m >= strend)
4623                 break;
4624             dstr = newSVpvn(s, m-s);
4625             if (make_mortal)
4626                 sv_2mortal(dstr);
4627             if (do_utf8)
4628                 (void)SvUTF8_on(dstr);
4629             XPUSHs(dstr);
4630             s = m;
4631         }
4632     }
4633     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4634              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4635              && (rx->reganch & ROPT_CHECK_ALL)
4636              && !(rx->reganch & ROPT_ANCH)) {
4637         const int tail = (rx->reganch & RE_INTUIT_TAIL);
4638         SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4639
4640         len = rx->minlen;
4641         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4642             const char c = *SvPV_nolen_const(csv);
4643             while (--limit) {
4644                 for (m = s; m < strend && *m != c; m++)
4645                     ;
4646                 if (m >= strend)
4647                     break;
4648                 dstr = newSVpvn(s, m-s);
4649                 if (make_mortal)
4650                     sv_2mortal(dstr);
4651                 if (do_utf8)
4652                     (void)SvUTF8_on(dstr);
4653                 XPUSHs(dstr);
4654                 /* The rx->minlen is in characters but we want to step
4655                  * s ahead by bytes. */
4656                 if (do_utf8)
4657                     s = (char*)utf8_hop((U8*)m, len);
4658                 else
4659                     s = m + len; /* Fake \n at the end */
4660             }
4661         }
4662         else {
4663             while (s < strend && --limit &&
4664               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4665                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4666             {
4667                 dstr = newSVpvn(s, m-s);
4668                 if (make_mortal)
4669                     sv_2mortal(dstr);
4670                 if (do_utf8)
4671                     (void)SvUTF8_on(dstr);
4672                 XPUSHs(dstr);
4673                 /* The rx->minlen is in characters but we want to step
4674                  * s ahead by bytes. */
4675                 if (do_utf8)
4676                     s = (char*)utf8_hop((U8*)m, len);
4677                 else
4678                     s = m + len; /* Fake \n at the end */
4679             }
4680         }
4681     }
4682     else {
4683         maxiters += slen * rx->nparens;
4684         while (s < strend && --limit)
4685         {
4686             I32 rex_return;
4687             PUTBACK;
4688             rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4689                             sv, NULL, 0);
4690             SPAGAIN;
4691             if (rex_return == 0)
4692                 break;
4693             TAINT_IF(RX_MATCH_TAINTED(rx));
4694             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4695                 m = s;
4696                 s = orig;
4697                 orig = rx->subbeg;
4698                 s = orig + (m - s);
4699                 strend = s + (strend - m);
4700             }
4701             m = rx->startp[0] + orig;
4702             dstr = newSVpvn(s, m-s);
4703             if (make_mortal)
4704                 sv_2mortal(dstr);
4705             if (do_utf8)
4706                 (void)SvUTF8_on(dstr);
4707             XPUSHs(dstr);
4708             if (rx->nparens) {
4709                 I32 i;
4710                 for (i = 1; i <= (I32)rx->nparens; i++) {
4711                     s = rx->startp[i] + orig;
4712                     m = rx->endp[i] + orig;
4713
4714                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4715                        parens that didn't match -- they should be set to
4716                        undef, not the empty string */
4717                     if (m >= orig && s >= orig) {
4718                         dstr = newSVpvn(s, m-s);
4719                     }
4720                     else
4721                         dstr = &PL_sv_undef;  /* undef, not "" */
4722                     if (make_mortal)
4723                         sv_2mortal(dstr);
4724                     if (do_utf8)
4725                         (void)SvUTF8_on(dstr);
4726                     XPUSHs(dstr);
4727                 }
4728             }
4729             s = rx->endp[0] + orig;
4730         }
4731     }
4732
4733     iters = (SP - PL_stack_base) - base;
4734     if (iters > maxiters)
4735         DIE(aTHX_ "Split loop");
4736
4737     /* keep field after final delim? */
4738     if (s < strend || (iters && origlimit)) {
4739         const STRLEN l = strend - s;
4740         dstr = newSVpvn(s, l);
4741         if (make_mortal)
4742             sv_2mortal(dstr);
4743         if (do_utf8)
4744             (void)SvUTF8_on(dstr);
4745         XPUSHs(dstr);
4746         iters++;
4747     }
4748     else if (!origlimit) {
4749         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4750             if (TOPs && !make_mortal)
4751                 sv_2mortal(TOPs);
4752             iters--;
4753             *SP-- = &PL_sv_undef;
4754         }
4755     }
4756
4757     PUTBACK;
4758     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4759     SPAGAIN;
4760     if (realarray) {
4761         if (!mg) {
4762             if (SvSMAGICAL(ary)) {
4763                 PUTBACK;
4764                 mg_set((SV*)ary);
4765                 SPAGAIN;
4766             }
4767             if (gimme == G_ARRAY) {
4768                 EXTEND(SP, iters);
4769                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4770                 SP += iters;
4771                 RETURN;
4772             }
4773         }
4774         else {
4775             PUTBACK;
4776             ENTER;
4777             call_method("PUSH",G_SCALAR|G_DISCARD);
4778             LEAVE;
4779             SPAGAIN;
4780             if (gimme == G_ARRAY) {
4781                 I32 i;
4782                 /* EXTEND should not be needed - we just popped them */
4783                 EXTEND(SP, iters);
4784                 for (i=0; i < iters; i++) {
4785                     SV **svp = av_fetch(ary, i, FALSE);
4786                     PUSHs((svp) ? *svp : &PL_sv_undef);
4787                 }
4788                 RETURN;
4789             }
4790         }
4791     }
4792     else {
4793         if (gimme == G_ARRAY)
4794             RETURN;
4795     }
4796
4797     GETTARGET;
4798     PUSHi(iters);
4799     RETURN;
4800 }
4801
4802 PP(pp_lock)
4803 {
4804     dVAR;
4805     dSP;
4806     dTOPss;
4807     SV *retsv = sv;
4808     SvLOCK(sv);
4809     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4810         || SvTYPE(retsv) == SVt_PVCV) {
4811         retsv = refto(retsv);
4812     }
4813     SETs(retsv);
4814     RETURN;
4815 }
4816
4817
4818 PP(unimplemented_op)
4819 {
4820     dVAR;
4821     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4822         PL_op->op_type);
4823 }
4824
4825 /*
4826  * Local variables:
4827  * c-indentation-style: bsd
4828  * c-basic-offset: 4
4829  * indent-tabs-mode: t
4830  * End:
4831  *
4832  * ex: set ts=8 sts=4 sw=4 noet:
4833  */