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