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