pp.c

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