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