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