pp.c

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