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