pp.c

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