pp.c

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