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             else
3130                 SvOK_off(TARG);
3131
3132             LvTYPE(TARG) = 'x';
3133             if (LvTARG(TARG) != sv) {
3134                 if (LvTARG(TARG))
3135                     SvREFCNT_dec(LvTARG(TARG));
3136                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3137             }
3138             LvTARGOFF(TARG) = upos;
3139             LvTARGLEN(TARG) = urem;
3140         }
3141     }
3142     SPAGAIN;
3143     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3144     RETURN;
3145 }
3146
3147 PP(pp_vec)
3148 {
3149     dVAR; dSP; dTARGET;
3150     register const IV size   = POPi;
3151     register const IV offset = POPi;
3152     register SV * const src = POPs;
3153     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3154
3155     SvTAINTED_off(TARG);                /* decontaminate */
3156     if (lvalue) {                       /* it's an lvalue! */
3157         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3158             TARG = sv_newmortal();
3159         if (SvTYPE(TARG) < SVt_PVLV) {
3160             sv_upgrade(TARG, SVt_PVLV);
3161             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3162         }
3163         LvTYPE(TARG) = 'v';
3164         if (LvTARG(TARG) != src) {
3165             if (LvTARG(TARG))
3166                 SvREFCNT_dec(LvTARG(TARG));
3167             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3168         }
3169         LvTARGOFF(TARG) = offset;
3170         LvTARGLEN(TARG) = size;
3171     }
3172
3173     sv_setuv(TARG, do_vecget(src, offset, size));
3174     PUSHs(TARG);
3175     RETURN;
3176 }
3177
3178 PP(pp_index)
3179 {
3180     dVAR; dSP; dTARGET;
3181     SV *big;
3182     SV *little;
3183     SV *temp = NULL;
3184     STRLEN biglen;
3185     STRLEN llen = 0;
3186     I32 offset;
3187     I32 retval;
3188     const char *big_p;
3189     const char *little_p;
3190     const I32 arybase = CopARYBASE_get(PL_curcop);
3191     bool big_utf8;
3192     bool little_utf8;
3193     const bool is_index = PL_op->op_type == OP_INDEX;
3194
3195     if (MAXARG >= 3) {
3196         /* arybase is in characters, like offset, so combine prior to the
3197            UTF-8 to bytes calculation.  */
3198         offset = POPi - arybase;
3199     }
3200     little = POPs;
3201     big = POPs;
3202     big_p = SvPV_const(big, biglen);
3203     little_p = SvPV_const(little, llen);
3204
3205     big_utf8 = DO_UTF8(big);
3206     little_utf8 = DO_UTF8(little);
3207     if (big_utf8 ^ little_utf8) {
3208         /* One needs to be upgraded.  */
3209         if (little_utf8 && !PL_encoding) {
3210             /* Well, maybe instead we might be able to downgrade the small
3211                string?  */
3212             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3213                                                      &little_utf8);
3214             if (little_utf8) {
3215                 /* If the large string is ISO-8859-1, and it's not possible to
3216                    convert the small string to ISO-8859-1, then there is no
3217                    way that it could be found anywhere by index.  */
3218                 retval = -1;
3219                 goto fail;
3220             }
3221
3222             /* At this point, pv is a malloc()ed string. So donate it to temp
3223                to ensure it will get free()d  */
3224             little = temp = newSV(0);
3225             sv_usepvn(temp, pv, llen);
3226             little_p = SvPVX(little);
3227         } else {
3228             temp = little_utf8
3229                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3230
3231             if (PL_encoding) {
3232                 sv_recode_to_utf8(temp, PL_encoding);
3233             } else {
3234                 sv_utf8_upgrade(temp);
3235             }
3236             if (little_utf8) {
3237                 big = temp;
3238                 big_utf8 = TRUE;
3239                 big_p = SvPV_const(big, biglen);
3240             } else {
3241                 little = temp;
3242                 little_p = SvPV_const(little, llen);
3243             }
3244         }
3245     }
3246     if (SvGAMAGIC(big)) {
3247         /* Life just becomes a lot easier if I use a temporary here.
3248            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3249            will trigger magic and overloading again, as will fbm_instr()
3250         */
3251         big = sv_2mortal(newSVpvn(big_p, biglen));
3252         if (big_utf8)
3253             SvUTF8_on(big);
3254         big_p = SvPVX(big);
3255     }
3256     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3257         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3258            warn on undef, and we've already triggered a warning with the
3259            SvPV_const some lines above. We can't remove that, as we need to
3260            call some SvPV to trigger overloading early and find out if the
3261            string is UTF-8.
3262            This is all getting to messy. The API isn't quite clean enough,
3263            because data access has side effects.
3264         */
3265         little = sv_2mortal(newSVpvn(little_p, llen));
3266         if (little_utf8)
3267             SvUTF8_on(little);
3268         little_p = SvPVX(little);
3269     }
3270
3271     if (MAXARG < 3)
3272         offset = is_index ? 0 : biglen;
3273     else {
3274         if (big_utf8 && offset > 0)
3275             sv_pos_u2b(big, &offset, 0);
3276         if (!is_index)
3277             offset += llen;
3278     }
3279     if (offset < 0)
3280         offset = 0;
3281     else if (offset > (I32)biglen)
3282         offset = biglen;
3283     if (!(little_p = is_index
3284           ? fbm_instr((unsigned char*)big_p + offset,
3285                       (unsigned char*)big_p + biglen, little, 0)
3286           : rninstr(big_p,  big_p  + offset,
3287                     little_p, little_p + llen)))
3288         retval = -1;
3289     else {
3290         retval = little_p - big_p;
3291         if (retval > 0 && big_utf8)
3292             sv_pos_b2u(big, &retval);
3293     }
3294     if (temp)
3295         SvREFCNT_dec(temp);
3296  fail:
3297     PUSHi(retval + arybase);
3298     RETURN;
3299 }
3300
3301 PP(pp_sprintf)
3302 {
3303     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3304     do_sprintf(TARG, SP-MARK, MARK+1);
3305     TAINT_IF(SvTAINTED(TARG));
3306     SP = ORIGMARK;
3307     PUSHTARG;
3308     RETURN;
3309 }
3310
3311 PP(pp_ord)
3312 {
3313     dVAR; dSP; dTARGET;
3314
3315     SV *argsv = POPs;
3316     STRLEN len;
3317     const U8 *s = (U8*)SvPV_const(argsv, len);
3318
3319     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3320         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3321         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3322         argsv = tmpsv;
3323     }
3324
3325     XPUSHu(DO_UTF8(argsv) ?
3326            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3327            (*s & 0xff));
3328
3329     RETURN;
3330 }
3331
3332 PP(pp_chr)
3333 {
3334     dVAR; dSP; dTARGET;
3335     char *tmps;
3336     UV value;
3337
3338     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3339          ||
3340          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3341         if (IN_BYTES) {
3342             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3343         } else {
3344             (void) POPs; /* Ignore the argument value. */
3345             value = UNICODE_REPLACEMENT;
3346         }
3347     } else {
3348         value = POPu;
3349     }
3350
3351     SvUPGRADE(TARG,SVt_PV);
3352
3353     if (value > 255 && !IN_BYTES) {
3354         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3355         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3356         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3357         *tmps = '\0';
3358         (void)SvPOK_only(TARG);
3359         SvUTF8_on(TARG);
3360         XPUSHs(TARG);
3361         RETURN;
3362     }
3363
3364     SvGROW(TARG,2);
3365     SvCUR_set(TARG, 1);
3366     tmps = SvPVX(TARG);
3367     *tmps++ = (char)value;
3368     *tmps = '\0';
3369     (void)SvPOK_only(TARG);
3370     if (PL_encoding && !IN_BYTES) {
3371         sv_recode_to_utf8(TARG, PL_encoding);
3372         tmps = SvPVX(TARG);
3373         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3374             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3375             SvGROW(TARG, 3);
3376             tmps = SvPVX(TARG);
3377             SvCUR_set(TARG, 2);
3378             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3379             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3380             *tmps = '\0';
3381             SvUTF8_on(TARG);
3382         }
3383     }
3384     XPUSHs(TARG);
3385     RETURN;
3386 }
3387
3388 PP(pp_crypt)
3389 {
3390 #ifdef HAS_CRYPT
3391     dVAR; dSP; dTARGET;
3392     dPOPTOPssrl;
3393     STRLEN len;
3394     const char *tmps = SvPV_const(left, len);
3395
3396     if (DO_UTF8(left)) {
3397          /* If Unicode, try to downgrade.
3398           * If not possible, croak.
3399           * Yes, we made this up.  */
3400          SV* const tsv = sv_2mortal(newSVsv(left));
3401
3402          SvUTF8_on(tsv);
3403          sv_utf8_downgrade(tsv, FALSE);
3404          tmps = SvPV_const(tsv, len);
3405     }
3406 #   ifdef USE_ITHREADS
3407 #     ifdef HAS_CRYPT_R
3408     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3409       /* This should be threadsafe because in ithreads there is only
3410        * one thread per interpreter.  If this would not be true,
3411        * we would need a mutex to protect this malloc. */
3412         PL_reentrant_buffer->_crypt_struct_buffer =
3413           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3414 #if defined(__GLIBC__) || defined(__EMX__)
3415         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3416             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3417             /* work around glibc-2.2.5 bug */
3418             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3419         }
3420 #endif
3421     }
3422 #     endif /* HAS_CRYPT_R */
3423 #   endif /* USE_ITHREADS */
3424 #   ifdef FCRYPT
3425     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3426 #   else
3427     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3428 #   endif
3429     SETs(TARG);
3430     RETURN;
3431 #else
3432     DIE(aTHX_
3433       "The crypt() function is unimplemented due to excessive paranoia.");
3434 #endif
3435 }
3436
3437 PP(pp_ucfirst)
3438 {
3439     dVAR;
3440     dSP;
3441     SV *source = TOPs;
3442     STRLEN slen;
3443     STRLEN need;
3444     SV *dest;
3445     bool inplace = TRUE;
3446     bool doing_utf8;
3447     const int op_type = PL_op->op_type;
3448     const U8 *s;
3449     U8 *d;
3450     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3451     STRLEN ulen;
3452     STRLEN tculen;
3453
3454     SvGETMAGIC(source);
3455     if (SvOK(source)) {
3456         s = (const U8*)SvPV_nomg_const(source, slen);
3457     } else {
3458         s = (const U8*)"";
3459         slen = 0;
3460     }
3461
3462     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3463         doing_utf8 = TRUE;
3464         utf8_to_uvchr(s, &ulen);
3465         if (op_type == OP_UCFIRST) {
3466             toTITLE_utf8(s, tmpbuf, &tculen);
3467         } else {
3468             toLOWER_utf8(s, tmpbuf, &tculen);
3469         }
3470         /* If the two differ, we definately cannot do inplace.  */
3471         inplace = (ulen == tculen);
3472         need = slen + 1 - ulen + tculen;
3473     } else {
3474         doing_utf8 = FALSE;
3475         need = slen + 1;
3476     }
3477
3478     if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3479         /* We can convert in place.  */
3480
3481         dest = source;
3482         s = d = (U8*)SvPV_force_nomg(source, slen);
3483     } else {
3484         dTARGET;
3485
3486         dest = TARG;
3487
3488         SvUPGRADE(dest, SVt_PV);
3489         d = (U8*)SvGROW(dest, need);
3490         (void)SvPOK_only(dest);
3491
3492         SETs(dest);
3493
3494         inplace = FALSE;
3495     }
3496
3497     if (doing_utf8) {
3498         if(!inplace) {
3499             /* slen is the byte length of the whole SV.
3500              * ulen is the byte length of the original Unicode character
3501              * stored as UTF-8 at s.
3502              * tculen is the byte length of the freshly titlecased (or
3503              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3504              * We first set the result to be the titlecased (/lowercased)
3505              * character, and then append the rest of the SV data. */
3506             sv_setpvn(dest, (char*)tmpbuf, tculen);
3507             if (slen > ulen)
3508                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3509             SvUTF8_on(dest);
3510         }
3511         else {
3512             Copy(tmpbuf, d, tculen, U8);
3513             SvCUR_set(dest, need - 1);
3514         }
3515     }
3516     else {
3517         if (*s) {
3518             if (IN_LOCALE_RUNTIME) {
3519                 TAINT;
3520                 SvTAINTED_on(dest);
3521                 *d = (op_type == OP_UCFIRST)
3522                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3523             }
3524             else
3525                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3526         } else {
3527             /* See bug #39028  */
3528             *d = *s;
3529         }
3530
3531         if (SvUTF8(source))
3532             SvUTF8_on(dest);
3533
3534         if (!inplace) {
3535             /* This will copy the trailing NUL  */
3536             Copy(s + 1, d + 1, slen, U8);
3537             SvCUR_set(dest, need - 1);
3538         }
3539     }
3540     SvSETMAGIC(dest);
3541     RETURN;
3542 }
3543
3544 /* There's so much setup/teardown code common between uc and lc, I wonder if
3545    it would be worth merging the two, and just having a switch outside each
3546    of the three tight loops.  */
3547 PP(pp_uc)
3548 {
3549     dVAR;
3550     dSP;
3551     SV *source = TOPs;
3552     STRLEN len;
3553     STRLEN min;
3554     SV *dest;
3555     const U8 *s;
3556     U8 *d;
3557
3558     SvGETMAGIC(source);
3559
3560     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3561         && !DO_UTF8(source)) {
3562         /* We can convert in place.  */
3563
3564         dest = source;
3565         s = d = (U8*)SvPV_force_nomg(source, len);
3566         min = len + 1;
3567     } else {
3568         dTARGET;
3569
3570         dest = TARG;
3571
3572         /* The old implementation would copy source into TARG at this point.
3573            This had the side effect that if source was undef, TARG was now
3574            an undefined SV with PADTMP set, and they don't warn inside
3575            sv_2pv_flags(). However, we're now getting the PV direct from
3576            source, which doesn't have PADTMP set, so it would warn. Hence the
3577            little games.  */
3578
3579         if (SvOK(source)) {
3580             s = (const U8*)SvPV_nomg_const(source, len);
3581         } else {
3582             s = (const U8*)"";
3583             len = 0;
3584         }
3585         min = len + 1;
3586
3587         SvUPGRADE(dest, SVt_PV);
3588         d = (U8*)SvGROW(dest, min);
3589         (void)SvPOK_only(dest);
3590
3591         SETs(dest);
3592     }
3593
3594     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3595        to check DO_UTF8 again here.  */
3596
3597     if (DO_UTF8(source)) {
3598         const U8 *const send = s + len;
3599         U8 tmpbuf[UTF8_MAXBYTES+1];
3600
3601         while (s < send) {
3602             const STRLEN u = UTF8SKIP(s);
3603             STRLEN ulen;
3604
3605             toUPPER_utf8(s, tmpbuf, &ulen);
3606             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3607                 /* If the eventually required minimum size outgrows
3608                  * the available space, we need to grow. */
3609                 const UV o = d - (U8*)SvPVX_const(dest);
3610
3611                 /* If someone uppercases one million U+03B0s we SvGROW() one
3612                  * million times.  Or we could try guessing how much to
3613                  allocate without allocating too much.  Such is life. */
3614                 SvGROW(dest, min);
3615                 d = (U8*)SvPVX(dest) + o;
3616             }
3617             Copy(tmpbuf, d, ulen, U8);
3618             d += ulen;
3619             s += u;
3620         }
3621         SvUTF8_on(dest);
3622         *d = '\0';
3623         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3624     } else {
3625         if (len) {
3626             const U8 *const send = s + len;
3627             if (IN_LOCALE_RUNTIME) {
3628                 TAINT;
3629                 SvTAINTED_on(dest);
3630                 for (; s < send; d++, s++)
3631                     *d = toUPPER_LC(*s);
3632             }
3633             else {
3634                 for (; s < send; d++, s++)
3635                     *d = toUPPER(*s);
3636             }
3637         }
3638         if (source != dest) {
3639             *d = '\0';
3640             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3641         }
3642     }
3643     SvSETMAGIC(dest);
3644     RETURN;
3645 }
3646
3647 PP(pp_lc)
3648 {
3649     dVAR;
3650     dSP;
3651     SV *source = TOPs;
3652     STRLEN len;
3653     STRLEN min;
3654     SV *dest;
3655     const U8 *s;
3656     U8 *d;
3657
3658     SvGETMAGIC(source);
3659
3660     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3661         && !DO_UTF8(source)) {
3662         /* We can convert in place.  */
3663
3664         dest = source;
3665         s = d = (U8*)SvPV_force_nomg(source, len);
3666         min = len + 1;
3667     } else {
3668         dTARGET;
3669
3670         dest = TARG;
3671
3672         /* The old implementation would copy source into TARG at this point.
3673            This had the side effect that if source was undef, TARG was now
3674            an undefined SV with PADTMP set, and they don't warn inside
3675            sv_2pv_flags(). However, we're now getting the PV direct from
3676            source, which doesn't have PADTMP set, so it would warn. Hence the
3677            little games.  */
3678
3679         if (SvOK(source)) {
3680             s = (const U8*)SvPV_nomg_const(source, len);
3681         } else {
3682             s = (const U8*)"";
3683             len = 0;
3684         }
3685         min = len + 1;
3686
3687         SvUPGRADE(dest, SVt_PV);
3688         d = (U8*)SvGROW(dest, min);
3689         (void)SvPOK_only(dest);
3690
3691         SETs(dest);
3692     }
3693
3694     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3695        to check DO_UTF8 again here.  */
3696
3697     if (DO_UTF8(source)) {
3698         const U8 *const send = s + len;
3699         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3700
3701         while (s < send) {
3702             const STRLEN u = UTF8SKIP(s);
3703             STRLEN ulen;
3704             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3705
3706 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3707             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3708                 NOOP;
3709                 /*
3710                  * Now if the sigma is NOT followed by
3711                  * /$ignorable_sequence$cased_letter/;
3712                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3713                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3714                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3715                  * then it should be mapped to 0x03C2,
3716                  * (GREEK SMALL LETTER FINAL SIGMA),
3717                  * instead of staying 0x03A3.
3718                  * "should be": in other words, this is not implemented yet.
3719                  * See lib/unicore/SpecialCasing.txt.
3720                  */
3721             }
3722             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3723                 /* If the eventually required minimum size outgrows
3724                  * the available space, we need to grow. */
3725                 const UV o = d - (U8*)SvPVX_const(dest);
3726
3727                 /* If someone lowercases one million U+0130s we SvGROW() one
3728                  * million times.  Or we could try guessing how much to
3729                  allocate without allocating too much.  Such is life. */
3730                 SvGROW(dest, min);
3731                 d = (U8*)SvPVX(dest) + o;
3732             }
3733             Copy(tmpbuf, d, ulen, U8);
3734             d += ulen;
3735             s += u;
3736         }
3737         SvUTF8_on(dest);
3738         *d = '\0';
3739         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3740     } else {
3741         if (len) {
3742             const U8 *const send = s + len;
3743             if (IN_LOCALE_RUNTIME) {
3744                 TAINT;
3745                 SvTAINTED_on(dest);
3746                 for (; s < send; d++, s++)
3747                     *d = toLOWER_LC(*s);
3748             }
3749             else {
3750                 for (; s < send; d++, s++)
3751                     *d = toLOWER(*s);
3752             }
3753         }
3754         if (source != dest) {
3755             *d = '\0';
3756             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3757         }
3758     }
3759     SvSETMAGIC(dest);
3760     RETURN;
3761 }
3762
3763 PP(pp_quotemeta)
3764 {
3765     dVAR; dSP; dTARGET;
3766     SV * const sv = TOPs;
3767     STRLEN len;
3768     register const char *s = SvPV_const(sv,len);
3769
3770     SvUTF8_off(TARG);                           /* decontaminate */
3771     if (len) {
3772         register char *d;
3773         SvUPGRADE(TARG, SVt_PV);
3774         SvGROW(TARG, (len * 2) + 1);
3775         d = SvPVX(TARG);
3776         if (DO_UTF8(sv)) {
3777             while (len) {
3778                 if (UTF8_IS_CONTINUED(*s)) {
3779                     STRLEN ulen = UTF8SKIP(s);
3780                     if (ulen > len)
3781                         ulen = len;
3782                     len -= ulen;
3783                     while (ulen--)
3784                         *d++ = *s++;
3785                 }
3786                 else {
3787                     if (!isALNUM(*s))
3788                         *d++ = '\\';
3789                     *d++ = *s++;
3790                     len--;
3791                 }
3792             }
3793             SvUTF8_on(TARG);
3794         }
3795         else {
3796             while (len--) {
3797                 if (!isALNUM(*s))
3798                     *d++ = '\\';
3799                 *d++ = *s++;
3800             }
3801         }
3802         *d = '\0';
3803         SvCUR_set(TARG, d - SvPVX_const(TARG));
3804         (void)SvPOK_only_UTF8(TARG);
3805     }
3806     else
3807         sv_setpvn(TARG, s, len);
3808     SETs(TARG);
3809     if (SvSMAGICAL(TARG))
3810         mg_set(TARG);
3811     RETURN;
3812 }
3813
3814 /* Arrays. */
3815
3816 PP(pp_aslice)
3817 {
3818     dVAR; dSP; dMARK; dORIGMARK;
3819     register AV* const av = (AV*)POPs;
3820     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3821
3822     if (SvTYPE(av) == SVt_PVAV) {
3823         const I32 arybase = CopARYBASE_get(PL_curcop);
3824         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3825             register SV **svp;
3826             I32 max = -1;
3827             for (svp = MARK + 1; svp <= SP; svp++) {
3828                 const I32 elem = SvIVx(*svp);
3829                 if (elem > max)
3830                     max = elem;
3831             }
3832             if (max > AvMAX(av))
3833                 av_extend(av, max);
3834         }
3835         while (++MARK <= SP) {
3836             register SV **svp;
3837             I32 elem = SvIVx(*MARK);
3838
3839             if (elem > 0)
3840                 elem -= arybase;
3841             svp = av_fetch(av, elem, lval);
3842             if (lval) {
3843                 if (!svp || *svp == &PL_sv_undef)
3844                     DIE(aTHX_ PL_no_aelem, elem);
3845                 if (PL_op->op_private & OPpLVAL_INTRO)
3846                     save_aelem(av, elem, svp);
3847             }
3848             *MARK = svp ? *svp : &PL_sv_undef;
3849         }
3850     }
3851     if (GIMME != G_ARRAY) {
3852         MARK = ORIGMARK;
3853         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3854         SP = MARK;
3855     }
3856     RETURN;
3857 }
3858
3859 /* Associative arrays. */
3860
3861 PP(pp_each)
3862 {
3863     dVAR;
3864     dSP;
3865     HV * const hash = (HV*)POPs;
3866     HE *entry;
3867     const I32 gimme = GIMME_V;
3868
3869     PUTBACK;
3870     /* might clobber stack_sp */
3871     entry = hv_iternext(hash);
3872     SPAGAIN;
3873
3874     EXTEND(SP, 2);
3875     if (entry) {
3876         SV* const sv = hv_iterkeysv(entry);
3877         PUSHs(sv);      /* won't clobber stack_sp */
3878         if (gimme == G_ARRAY) {
3879             SV *val;
3880             PUTBACK;
3881             /* might clobber stack_sp */
3882             val = hv_iterval(hash, entry);
3883             SPAGAIN;
3884             PUSHs(val);
3885         }
3886     }
3887     else if (gimme == G_SCALAR)
3888         RETPUSHUNDEF;
3889
3890     RETURN;
3891 }
3892
3893 PP(pp_delete)
3894 {
3895     dVAR;
3896     dSP;
3897     const I32 gimme = GIMME_V;
3898     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3899
3900     if (PL_op->op_private & OPpSLICE) {
3901         dMARK; dORIGMARK;
3902         HV * const hv = (HV*)POPs;
3903         const U32 hvtype = SvTYPE(hv);
3904         if (hvtype == SVt_PVHV) {                       /* hash element */
3905             while (++MARK <= SP) {
3906                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3907                 *MARK = sv ? sv : &PL_sv_undef;
3908             }
3909         }
3910         else if (hvtype == SVt_PVAV) {                  /* array element */
3911             if (PL_op->op_flags & OPf_SPECIAL) {
3912                 while (++MARK <= SP) {
3913                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3914                     *MARK = sv ? sv : &PL_sv_undef;
3915                 }
3916             }
3917         }
3918         else
3919             DIE(aTHX_ "Not a HASH reference");
3920         if (discard)
3921             SP = ORIGMARK;
3922         else if (gimme == G_SCALAR) {
3923             MARK = ORIGMARK;
3924             if (SP > MARK)
3925                 *++MARK = *SP;
3926             else
3927                 *++MARK = &PL_sv_undef;
3928             SP = MARK;
3929         }
3930     }
3931     else {
3932         SV *keysv = POPs;
3933         HV * const hv = (HV*)POPs;
3934         SV *sv;
3935         if (SvTYPE(hv) == SVt_PVHV)
3936             sv = hv_delete_ent(hv, keysv, discard, 0);
3937         else if (SvTYPE(hv) == SVt_PVAV) {
3938             if (PL_op->op_flags & OPf_SPECIAL)
3939                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3940             else
3941                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3942         }
3943         else
3944             DIE(aTHX_ "Not a HASH reference");
3945         if (!sv)
3946             sv = &PL_sv_undef;
3947         if (!discard)
3948             PUSHs(sv);
3949     }
3950     RETURN;
3951 }
3952
3953 PP(pp_exists)
3954 {
3955     dVAR;
3956     dSP;
3957     SV *tmpsv;
3958     HV *hv;
3959
3960     if (PL_op->op_private & OPpEXISTS_SUB) {
3961         GV *gv;
3962         SV * const sv = POPs;
3963         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3964         if (cv)
3965             RETPUSHYES;
3966         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3967             RETPUSHYES;
3968         RETPUSHNO;
3969     }
3970     tmpsv = POPs;
3971     hv = (HV*)POPs;
3972     if (SvTYPE(hv) == SVt_PVHV) {
3973         if (hv_exists_ent(hv, tmpsv, 0))
3974             RETPUSHYES;
3975     }
3976     else if (SvTYPE(hv) == SVt_PVAV) {
3977         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3978             if (av_exists((AV*)hv, SvIV(tmpsv)))
3979                 RETPUSHYES;
3980         }
3981     }
3982     else {
3983         DIE(aTHX_ "Not a HASH reference");
3984     }
3985     RETPUSHNO;
3986 }
3987
3988 PP(pp_hslice)
3989 {
3990     dVAR; dSP; dMARK; dORIGMARK;
3991     register HV * const hv = (HV*)POPs;
3992     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3993     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3994     bool other_magic = FALSE;
3995
3996     if (localizing) {
3997         MAGIC *mg;
3998         HV *stash;
3999
4000         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4001             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4002              /* Try to preserve the existenceness of a tied hash
4003               * element by using EXISTS and DELETE if possible.
4004               * Fallback to FETCH and STORE otherwise */
4005              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4006              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4007              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4008     }
4009
4010     while (++MARK <= SP) {
4011         SV * const keysv = *MARK;
4012         SV **svp;
4013         HE *he;
4014         bool preeminent = FALSE;
4015
4016         if (localizing) {
4017             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4018                 hv_exists_ent(hv, keysv, 0);
4019         }
4020
4021         he = hv_fetch_ent(hv, keysv, lval, 0);
4022         svp = he ? &HeVAL(he) : 0;
4023
4024         if (lval) {
4025             if (!svp || *svp == &PL_sv_undef) {
4026                 DIE(aTHX_ PL_no_helem_sv, keysv);
4027             }
4028             if (localizing) {
4029                 if (HvNAME_get(hv) && isGV(*svp))
4030                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4031                 else {
4032                     if (preeminent)
4033                         save_helem(hv, keysv, svp);
4034                     else {
4035                         STRLEN keylen;
4036                         const char * const key = SvPV_const(keysv, keylen);
4037                         SAVEDELETE(hv, savepvn(key,keylen),
4038                                    SvUTF8(keysv) ? -keylen : keylen);
4039                     }
4040                 }
4041             }
4042         }
4043         *MARK = svp ? *svp : &PL_sv_undef;
4044     }
4045     if (GIMME != G_ARRAY) {
4046         MARK = ORIGMARK;
4047         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4048         SP = MARK;
4049     }
4050     RETURN;
4051 }
4052
4053 /* List operators. */
4054
4055 PP(pp_list)
4056 {
4057     dVAR; dSP; dMARK;
4058     if (GIMME != G_ARRAY) {
4059         if (++MARK <= SP)
4060             *MARK = *SP;                /* unwanted list, return last item */
4061         else
4062             *MARK = &PL_sv_undef;
4063         SP = MARK;
4064     }
4065     RETURN;
4066 }
4067
4068 PP(pp_lslice)
4069 {
4070     dVAR;
4071     dSP;
4072     SV ** const lastrelem = PL_stack_sp;
4073     SV ** const lastlelem = PL_stack_base + POPMARK;
4074     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4075     register SV ** const firstrelem = lastlelem + 1;
4076     const I32 arybase = CopARYBASE_get(PL_curcop);
4077     I32 is_something_there = PL_op->op_flags & OPf_MOD;
4078
4079     register const I32 max = lastrelem - lastlelem;
4080     register SV **lelem;
4081
4082     if (GIMME != G_ARRAY) {
4083         I32 ix = SvIVx(*lastlelem);
4084         if (ix < 0)
4085             ix += max;
4086         else
4087             ix -= arybase;
4088         if (ix < 0 || ix >= max)
4089             *firstlelem = &PL_sv_undef;
4090         else
4091             *firstlelem = firstrelem[ix];
4092         SP = firstlelem;
4093         RETURN;
4094     }
4095
4096     if (max == 0) {
4097         SP = firstlelem - 1;
4098         RETURN;
4099     }
4100
4101     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4102         I32 ix = SvIVx(*lelem);
4103         if (ix < 0)
4104             ix += max;
4105         else
4106             ix -= arybase;
4107         if (ix < 0 || ix >= max)
4108             *lelem = &PL_sv_undef;
4109         else {
4110             is_something_there = TRUE;
4111             if (!(*lelem = firstrelem[ix]))
4112                 *lelem = &PL_sv_undef;
4113         }
4114     }
4115     if (is_something_there)
4116         SP = lastlelem;
4117     else
4118         SP = firstlelem - 1;
4119     RETURN;
4120 }
4121
4122 PP(pp_anonlist)
4123 {
4124     dVAR; dSP; dMARK; dORIGMARK;
4125     const I32 items = SP - MARK;
4126     SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4127     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4128     XPUSHs(av);
4129     RETURN;
4130 }
4131
4132 PP(pp_anonhash)
4133 {
4134     dVAR; dSP; dMARK; dORIGMARK;
4135     HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4136
4137     while (MARK < SP) {
4138         SV * const key = *++MARK;
4139         SV * const val = newSV(0);
4140         if (MARK < SP)
4141             sv_setsv(val, *++MARK);
4142         else if (ckWARN(WARN_MISC))
4143             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4144         (void)hv_store_ent(hv,key,val,0);
4145     }
4146     SP = ORIGMARK;
4147     XPUSHs((SV*)hv);
4148     RETURN;
4149 }
4150
4151 PP(pp_splice)
4152 {
4153     dVAR; dSP; dMARK; dORIGMARK;
4154     register AV *ary = (AV*)*++MARK;
4155     register SV **src;
4156     register SV **dst;
4157     register I32 i;
4158     register I32 offset;
4159     register I32 length;
4160     I32 newlen;
4161     I32 after;
4162     I32 diff;
4163     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4164
4165     if (mg) {
4166         *MARK-- = SvTIED_obj((SV*)ary, mg);
4167         PUSHMARK(MARK);
4168         PUTBACK;
4169         ENTER;
4170         call_method("SPLICE",GIMME_V);
4171         LEAVE;
4172         SPAGAIN;
4173         RETURN;
4174     }
4175
4176     SP++;
4177
4178     if (++MARK < SP) {
4179         offset = i = SvIVx(*MARK);
4180         if (offset < 0)
4181             offset += AvFILLp(ary) + 1;
4182         else
4183             offset -= CopARYBASE_get(PL_curcop);
4184         if (offset < 0)
4185             DIE(aTHX_ PL_no_aelem, i);
4186         if (++MARK < SP) {
4187             length = SvIVx(*MARK++);
4188             if (length < 0) {
4189                 length += AvFILLp(ary) - offset + 1;
4190                 if (length < 0)
4191                     length = 0;
4192             }
4193         }
4194         else
4195             length = AvMAX(ary) + 1;            /* close enough to infinity */
4196     }
4197     else {
4198         offset = 0;
4199         length = AvMAX(ary) + 1;
4200     }
4201     if (offset > AvFILLp(ary) + 1) {
4202         if (ckWARN(WARN_MISC))
4203             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4204         offset = AvFILLp(ary) + 1;
4205     }
4206     after = AvFILLp(ary) + 1 - (offset + length);
4207     if (after < 0) {                            /* not that much array */
4208         length += after;                        /* offset+length now in array */
4209         after = 0;
4210         if (!AvALLOC(ary))
4211             av_extend(ary, 0);
4212     }
4213
4214     /* At this point, MARK .. SP-1 is our new LIST */
4215
4216     newlen = SP - MARK;
4217     diff = newlen - length;
4218     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4219         av_reify(ary);
4220
4221     /* make new elements SVs now: avoid problems if they're from the array */
4222     for (dst = MARK, i = newlen; i; i--) {
4223         SV * const h = *dst;
4224         *dst++ = newSVsv(h);
4225     }
4226
4227     if (diff < 0) {                             /* shrinking the area */
4228         SV **tmparyval = NULL;
4229         if (newlen) {
4230             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4231             Copy(MARK, tmparyval, newlen, SV*);
4232         }
4233
4234         MARK = ORIGMARK + 1;
4235         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4236             MEXTEND(MARK, length);
4237             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4238             if (AvREAL(ary)) {
4239                 EXTEND_MORTAL(length);
4240                 for (i = length, dst = MARK; i; i--) {
4241                     sv_2mortal(*dst);   /* free them eventualy */
4242                     dst++;
4243                 }
4244             }
4245             MARK += length - 1;
4246         }
4247         else {
4248             *MARK = AvARRAY(ary)[offset+length-1];
4249             if (AvREAL(ary)) {
4250                 sv_2mortal(*MARK);
4251                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4252                     SvREFCNT_dec(*dst++);       /* free them now */
4253             }
4254         }
4255         AvFILLp(ary) += diff;
4256
4257         /* pull up or down? */
4258
4259         if (offset < after) {                   /* easier to pull up */
4260             if (offset) {                       /* esp. if nothing to pull */
4261                 src = &AvARRAY(ary)[offset-1];
4262                 dst = src - diff;               /* diff is negative */
4263                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4264                     *dst-- = *src--;
4265             }
4266             dst = AvARRAY(ary);
4267             SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4268             AvMAX(ary) += diff;
4269         }
4270         else {
4271             if (after) {                        /* anything to pull down? */
4272                 src = AvARRAY(ary) + offset + length;
4273                 dst = src + diff;               /* diff is negative */
4274                 Move(src, dst, after, SV*);
4275             }
4276             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4277                                                 /* avoid later double free */
4278         }
4279         i = -diff;
4280         while (i)
4281             dst[--i] = &PL_sv_undef;
4282
4283         if (newlen) {
4284             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4285             Safefree(tmparyval);
4286         }
4287     }
4288     else {                                      /* no, expanding (or same) */
4289         SV** tmparyval = NULL;
4290         if (length) {
4291             Newx(tmparyval, length, SV*);       /* so remember deletion */
4292             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4293         }
4294
4295         if (diff > 0) {                         /* expanding */
4296             /* push up or down? */
4297             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4298                 if (offset) {
4299                     src = AvARRAY(ary);
4300                     dst = src - diff;
4301                     Move(src, dst, offset, SV*);
4302                 }
4303                 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4304                 AvMAX(ary) += diff;
4305                 AvFILLp(ary) += diff;
4306             }
4307             else {
4308                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4309                     av_extend(ary, AvFILLp(ary) + diff);
4310                 AvFILLp(ary) += diff;
4311
4312                 if (after) {
4313                     dst = AvARRAY(ary) + AvFILLp(ary);
4314                     src = dst - diff;
4315                     for (i = after; i; i--) {
4316                         *dst-- = *src--;
4317                     }
4318                 }
4319             }
4320         }
4321
4322         if (newlen) {
4323             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4324         }
4325
4326         MARK = ORIGMARK + 1;
4327         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4328             if (length) {
4329                 Copy(tmparyval, MARK, length, SV*);
4330                 if (AvREAL(ary)) {
4331                     EXTEND_MORTAL(length);
4332                     for (i = length, dst = MARK; i; i--) {
4333                         sv_2mortal(*dst);       /* free them eventualy */
4334                         dst++;
4335                     }
4336                 }
4337             }
4338             MARK += length - 1;
4339         }
4340         else if (length--) {
4341             *MARK = tmparyval[length];
4342             if (AvREAL(ary)) {
4343                 sv_2mortal(*MARK);
4344                 while (length-- > 0)
4345                     SvREFCNT_dec(tmparyval[length]);
4346             }
4347         }
4348         else
4349             *MARK = &PL_sv_undef;
4350         Safefree(tmparyval);
4351     }
4352     SP = MARK;
4353     RETURN;
4354 }
4355
4356 PP(pp_push)
4357 {
4358     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4359     register AV * const ary = (AV*)*++MARK;
4360     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4361
4362     if (mg) {
4363         *MARK-- = SvTIED_obj((SV*)ary, mg);
4364         PUSHMARK(MARK);
4365         PUTBACK;
4366         ENTER;
4367         call_method("PUSH",G_SCALAR|G_DISCARD);
4368         LEAVE;
4369         SPAGAIN;
4370         SP = ORIGMARK;
4371         PUSHi( AvFILL(ary) + 1 );
4372     }
4373     else {
4374         for (++MARK; MARK <= SP; MARK++) {
4375             SV * const sv = newSV(0);
4376             if (*MARK)
4377                 sv_setsv(sv, *MARK);
4378             av_store(ary, AvFILLp(ary)+1, sv);
4379         }
4380         SP = ORIGMARK;
4381         PUSHi( AvFILLp(ary) + 1 );
4382     }
4383     RETURN;
4384 }
4385
4386 PP(pp_shift)
4387 {
4388     dVAR;
4389     dSP;
4390     AV * const av = (AV*)POPs;
4391     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4392     EXTEND(SP, 1);
4393     assert (sv);
4394     if (AvREAL(av))
4395         (void)sv_2mortal(sv);
4396     PUSHs(sv);
4397     RETURN;
4398 }
4399
4400 PP(pp_unshift)
4401 {
4402     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4403     register AV *ary = (AV*)*++MARK;
4404     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4405
4406     if (mg) {
4407         *MARK-- = SvTIED_obj((SV*)ary, mg);
4408         PUSHMARK(MARK);
4409         PUTBACK;
4410         ENTER;
4411         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4412         LEAVE;
4413         SPAGAIN;
4414     }
4415     else {
4416         register I32 i = 0;
4417         av_unshift(ary, SP - MARK);
4418         while (MARK < SP) {
4419             SV * const sv = newSVsv(*++MARK);
4420             (void)av_store(ary, i++, sv);
4421         }
4422     }
4423     SP = ORIGMARK;
4424     PUSHi( AvFILL(ary) + 1 );
4425     RETURN;
4426 }
4427
4428 PP(pp_reverse)
4429 {
4430     dVAR; dSP; dMARK;
4431     SV ** const oldsp = SP;
4432
4433     if (GIMME == G_ARRAY) {
4434         MARK++;
4435         while (MARK < SP) {
4436             register SV * const tmp = *MARK;
4437             *MARK++ = *SP;
4438             *SP-- = tmp;
4439         }
4440         /* safe as long as stack cannot get extended in the above */
4441         SP = oldsp;
4442     }
4443     else {
4444         register char *up;
4445         register char *down;
4446         register I32 tmp;
4447         dTARGET;
4448         STRLEN len;
4449         PADOFFSET padoff_du;
4450
4451         SvUTF8_off(TARG);                               /* decontaminate */
4452         if (SP - MARK > 1)
4453             do_join(TARG, &PL_sv_no, MARK, SP);
4454         else
4455             sv_setsv(TARG, (SP > MARK)
4456                     ? *SP
4457                     : (padoff_du = find_rundefsvoffset(),
4458                         (padoff_du == NOT_IN_PAD
4459                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4460                         ? DEFSV : PAD_SVl(padoff_du)));
4461         up = SvPV_force(TARG, len);
4462         if (len > 1) {
4463             if (DO_UTF8(TARG)) {        /* first reverse each character */
4464                 U8* s = (U8*)SvPVX(TARG);
4465                 const U8* send = (U8*)(s + len);
4466                 while (s < send) {
4467                     if (UTF8_IS_INVARIANT(*s)) {
4468                         s++;
4469                         continue;
4470                     }
4471                     else {
4472                         if (!utf8_to_uvchr(s, 0))
4473                             break;
4474                         up = (char*)s;
4475                         s += UTF8SKIP(s);
4476                         down = (char*)(s - 1);
4477                         /* reverse this character */
4478                         while (down > up) {
4479                             tmp = *up;
4480                             *up++ = *down;
4481                             *down-- = (char)tmp;
4482                         }
4483                     }
4484                 }
4485                 up = SvPVX(TARG);
4486             }
4487             down = SvPVX(TARG) + len - 1;
4488             while (down > up) {
4489                 tmp = *up;
4490                 *up++ = *down;
4491                 *down-- = (char)tmp;
4492             }
4493             (void)SvPOK_only_UTF8(TARG);
4494         }
4495         SP = MARK + 1;
4496         SETTARG;
4497     }
4498     RETURN;
4499 }
4500
4501 PP(pp_split)
4502 {
4503     dVAR; dSP; dTARG;
4504     AV *ary;
4505     register IV limit = POPi;                   /* note, negative is forever */
4506     SV * const sv = POPs;
4507     STRLEN len;
4508     register const char *s = SvPV_const(sv, len);
4509     const bool do_utf8 = DO_UTF8(sv);
4510     const char *strend = s + len;
4511     register PMOP *pm;
4512     register REGEXP *rx;
4513     register SV *dstr;
4514     register const char *m;
4515     I32 iters = 0;
4516     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4517     I32 maxiters = slen + 10;
4518     const char *orig;
4519     const I32 origlimit = limit;
4520     I32 realarray = 0;
4521     I32 base;
4522     const I32 gimme = GIMME_V;
4523     const I32 oldsave = PL_savestack_ix;
4524     I32 make_mortal = 1;
4525     bool multiline = 0;
4526     MAGIC *mg = NULL;
4527
4528 #ifdef DEBUGGING
4529     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4530 #else
4531     pm = (PMOP*)POPs;
4532 #endif
4533     if (!pm || !s)
4534         DIE(aTHX_ "panic: pp_split");
4535     rx = PM_GETRE(pm);
4536
4537     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4538              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4539
4540     RX_MATCH_UTF8_set(rx, do_utf8);
4541
4542     if (pm->op_pmreplroot) {
4543 #ifdef USE_ITHREADS
4544         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4545 #else
4546         ary = GvAVn((GV*)pm->op_pmreplroot);
4547 #endif
4548     }
4549     else if (gimme != G_ARRAY)
4550         ary = GvAVn(PL_defgv);
4551     else
4552         ary = NULL;
4553     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4554         realarray = 1;
4555         PUTBACK;
4556         av_extend(ary,0);
4557         av_clear(ary);
4558         SPAGAIN;
4559         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4560             PUSHMARK(SP);
4561             XPUSHs(SvTIED_obj((SV*)ary, mg));
4562         }
4563         else {
4564             if (!AvREAL(ary)) {
4565                 I32 i;
4566                 AvREAL_on(ary);
4567                 AvREIFY_off(ary);
4568                 for (i = AvFILLp(ary); i >= 0; i--)
4569                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4570             }
4571             /* temporarily switch stacks */
4572             SAVESWITCHSTACK(PL_curstack, ary);
4573             make_mortal = 0;
4574         }
4575     }
4576     base = SP - PL_stack_base;
4577     orig = s;
4578     if (pm->op_pmflags & PMf_SKIPWHITE) {
4579         if (pm->op_pmflags & PMf_LOCALE) {
4580             while (isSPACE_LC(*s))
4581                 s++;
4582         }
4583         else {
4584             while (isSPACE(*s))
4585                 s++;
4586         }
4587     }
4588     if (pm->op_pmflags & PMf_MULTILINE) {
4589         multiline = 1;
4590     }
4591
4592     if (!limit)
4593         limit = maxiters + 2;
4594     if (pm->op_pmflags & PMf_WHITE) {
4595         while (--limit) {
4596             m = s;
4597             while (m < strend &&
4598                    !((pm->op_pmflags & PMf_LOCALE)
4599                      ? isSPACE_LC(*m) : isSPACE(*m)))
4600                 ++m;
4601             if (m >= strend)
4602                 break;
4603
4604             dstr = newSVpvn(s, m-s);
4605             if (make_mortal)
4606                 sv_2mortal(dstr);
4607             if (do_utf8)
4608                 (void)SvUTF8_on(dstr);
4609             XPUSHs(dstr);
4610
4611             s = m + 1;
4612             while (s < strend &&
4613                    ((pm->op_pmflags & PMf_LOCALE)
4614                     ? isSPACE_LC(*s) : isSPACE(*s)))
4615                 ++s;
4616         }
4617     }
4618     else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4619         while (--limit) {
4620             for (m = s; m < strend && *m != '\n'; m++)
4621                 ;
4622             m++;
4623             if (m >= strend)
4624                 break;
4625             dstr = newSVpvn(s, m-s);
4626             if (make_mortal)
4627                 sv_2mortal(dstr);
4628             if (do_utf8)
4629                 (void)SvUTF8_on(dstr);
4630             XPUSHs(dstr);
4631             s = m;
4632         }
4633     }
4634     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4635              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4636              && (rx->reganch & ROPT_CHECK_ALL)
4637              && !(rx->reganch & ROPT_ANCH)) {
4638         const int tail = (rx->reganch & RE_INTUIT_TAIL);
4639         SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4640
4641         len = rx->minlen;
4642         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4643             const char c = *SvPV_nolen_const(csv);
4644             while (--limit) {
4645                 for (m = s; m < strend && *m != c; m++)
4646                     ;
4647                 if (m >= strend)
4648                     break;
4649                 dstr = newSVpvn(s, m-s);
4650                 if (make_mortal)
4651                     sv_2mortal(dstr);
4652                 if (do_utf8)
4653                     (void)SvUTF8_on(dstr);
4654                 XPUSHs(dstr);
4655                 /* The rx->minlen is in characters but we want to step
4656                  * s ahead by bytes. */
4657                 if (do_utf8)
4658                     s = (char*)utf8_hop((U8*)m, len);
4659                 else
4660                     s = m + len; /* Fake \n at the end */
4661             }
4662         }
4663         else {
4664             while (s < strend && --limit &&
4665               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4666                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4667             {
4668                 dstr = newSVpvn(s, m-s);
4669                 if (make_mortal)
4670                     sv_2mortal(dstr);
4671                 if (do_utf8)
4672                     (void)SvUTF8_on(dstr);
4673                 XPUSHs(dstr);
4674                 /* The rx->minlen is in characters but we want to step
4675                  * s ahead by bytes. */
4676                 if (do_utf8)
4677                     s = (char*)utf8_hop((U8*)m, len);
4678                 else
4679                     s = m + len; /* Fake \n at the end */
4680             }
4681         }
4682     }
4683     else {
4684         maxiters += slen * rx->nparens;
4685         while (s < strend && --limit)
4686         {
4687             I32 rex_return;
4688             PUTBACK;
4689             rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4690                             sv, NULL, 0);
4691             SPAGAIN;
4692             if (rex_return == 0)
4693                 break;
4694             TAINT_IF(RX_MATCH_TAINTED(rx));
4695             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4696                 m = s;
4697                 s = orig;
4698                 orig = rx->subbeg;
4699                 s = orig + (m - s);
4700                 strend = s + (strend - m);
4701             }
4702             m = rx->startp[0] + orig;
4703             dstr = newSVpvn(s, m-s);
4704             if (make_mortal)
4705                 sv_2mortal(dstr);
4706             if (do_utf8)
4707                 (void)SvUTF8_on(dstr);
4708             XPUSHs(dstr);
4709             if (rx->nparens) {
4710                 I32 i;
4711                 for (i = 1; i <= (I32)rx->nparens; i++) {
4712                     s = rx->startp[i] + orig;
4713                     m = rx->endp[i] + orig;
4714
4715                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4716                        parens that didn't match -- they should be set to
4717                        undef, not the empty string */
4718                     if (m >= orig && s >= orig) {
4719                         dstr = newSVpvn(s, m-s);
4720                     }
4721                     else
4722                         dstr = &PL_sv_undef;  /* undef, not "" */
4723                     if (make_mortal)
4724                         sv_2mortal(dstr);
4725                     if (do_utf8)
4726                         (void)SvUTF8_on(dstr);
4727                     XPUSHs(dstr);
4728                 }
4729             }
4730             s = rx->endp[0] + orig;
4731         }
4732     }
4733
4734     iters = (SP - PL_stack_base) - base;
4735     if (iters > maxiters)
4736         DIE(aTHX_ "Split loop");
4737
4738     /* keep field after final delim? */
4739     if (s < strend || (iters && origlimit)) {
4740         const STRLEN l = strend - s;
4741         dstr = newSVpvn(s, l);
4742         if (make_mortal)
4743             sv_2mortal(dstr);
4744         if (do_utf8)
4745             (void)SvUTF8_on(dstr);
4746         XPUSHs(dstr);
4747         iters++;
4748     }
4749     else if (!origlimit) {
4750         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4751             if (TOPs && !make_mortal)
4752                 sv_2mortal(TOPs);
4753             iters--;
4754             *SP-- = &PL_sv_undef;
4755         }
4756     }
4757
4758     PUTBACK;
4759     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4760     SPAGAIN;
4761     if (realarray) {
4762         if (!mg) {
4763             if (SvSMAGICAL(ary)) {
4764                 PUTBACK;
4765                 mg_set((SV*)ary);
4766                 SPAGAIN;
4767             }
4768             if (gimme == G_ARRAY) {
4769                 EXTEND(SP, iters);
4770                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4771                 SP += iters;
4772                 RETURN;
4773             }
4774         }
4775         else {
4776             PUTBACK;
4777             ENTER;
4778             call_method("PUSH",G_SCALAR|G_DISCARD);
4779             LEAVE;
4780             SPAGAIN;
4781             if (gimme == G_ARRAY) {
4782                 I32 i;
4783                 /* EXTEND should not be needed - we just popped them */
4784                 EXTEND(SP, iters);
4785                 for (i=0; i < iters; i++) {
4786                     SV **svp = av_fetch(ary, i, FALSE);
4787                     PUSHs((svp) ? *svp : &PL_sv_undef);
4788                 }
4789                 RETURN;
4790             }
4791         }
4792     }
4793     else {
4794         if (gimme == G_ARRAY)
4795             RETURN;
4796     }
4797
4798     GETTARGET;
4799     PUSHi(iters);
4800     RETURN;
4801 }
4802
4803 PP(pp_lock)
4804 {
4805     dVAR;
4806     dSP;
4807     dTOPss;
4808     SV *retsv = sv;
4809     SvLOCK(sv);
4810     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4811         || SvTYPE(retsv) == SVt_PVCV) {
4812         retsv = refto(retsv);
4813     }
4814     SETs(retsv);
4815     RETURN;
4816 }
4817
4818
4819 PP(unimplemented_op)
4820 {
4821     dVAR;
4822     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4823         PL_op->op_type);
4824 }
4825
4826 /*
4827  * Local variables:
4828  * c-indentation-style: bsd
4829  * c-basic-offset: 4
4830  * indent-tabs-mode: t
4831  * End:
4832  *
4833  * ex: set ts=8 sts=4 sw=4 noet:
4834  */