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