pp.c

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