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