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