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