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 #ifdef PERL_PRESERVE_IVUV
1548     else
1549 #endif
1550         if (SvROK(TOPs) && SvROK(TOPm1s)) {
1551             SP--;
1552             SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1553             RETURN;
1554         }
1555 #endif
1556     {
1557       dPOPnv;
1558       SETs(boolSV(TOPn < value));
1559       RETURN;
1560     }
1561 }
1562
1563 PP(pp_gt)
1564 {
1565     dSP; tryAMAGICbinSET(gt,0);
1566 #ifdef PERL_PRESERVE_IVUV
1567     SvIV_please(TOPs);
1568     if (SvIOK(TOPs)) {
1569         SvIV_please(TOPm1s);
1570         if (SvIOK(TOPm1s)) {
1571             bool auvok = SvUOK(TOPm1s);
1572             bool buvok = SvUOK(TOPs);
1573
1574             if (!auvok && !buvok) { /* ## IV > IV ## */
1575                 IV aiv = SvIVX(TOPm1s);
1576                 IV biv = SvIVX(TOPs);
1577
1578                 SP--;
1579                 SETs(boolSV(aiv > biv));
1580                 RETURN;
1581             }
1582             if (auvok && buvok) { /* ## UV > UV ## */
1583                 UV auv = SvUVX(TOPm1s);
1584                 UV buv = SvUVX(TOPs);
1585
1586                 SP--;
1587                 SETs(boolSV(auv > buv));
1588                 RETURN;
1589             }
1590             if (auvok) { /* ## UV > IV ## */
1591                 UV auv;
1592                 IV biv;
1593
1594                 biv = SvIVX(TOPs);
1595                 SP--;
1596                 if (biv < 0) {
1597                     /* As (a) is a UV, it's >=0, so it must be > */
1598                     SETs(&PL_sv_yes);
1599                     RETURN;
1600                 }
1601                 auv = SvUVX(TOPs);
1602                 SETs(boolSV(auv > (UV)biv));
1603                 RETURN;
1604             }
1605             { /* ## IV > UV ## */
1606                 IV aiv;
1607                 UV buv;
1608
1609                 aiv = SvIVX(TOPm1s);
1610                 if (aiv < 0) {
1611                     /* As (b) is a UV, it's >=0, so it cannot be > */
1612                     SP--;
1613                     SETs(&PL_sv_no);
1614                     RETURN;
1615                 }
1616                 buv = SvUVX(TOPs);
1617                 SP--;
1618                 SETs(boolSV((UV)aiv > buv));
1619                 RETURN;
1620             }
1621         }
1622     }
1623 #endif
1624 #ifndef NV_PRESERVES_UV
1625 #ifdef PERL_PRESERVE_IVUV
1626     else
1627 #endif
1628         if (SvROK(TOPs) && SvROK(TOPm1s)) {
1629         SP--;
1630         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1631         RETURN;
1632     }
1633 #endif
1634     {
1635       dPOPnv;
1636       SETs(boolSV(TOPn > value));
1637       RETURN;
1638     }
1639 }
1640
1641 PP(pp_le)
1642 {
1643     dSP; tryAMAGICbinSET(le,0);
1644 #ifdef PERL_PRESERVE_IVUV
1645     SvIV_please(TOPs);
1646     if (SvIOK(TOPs)) {
1647         SvIV_please(TOPm1s);
1648         if (SvIOK(TOPm1s)) {
1649             bool auvok = SvUOK(TOPm1s);
1650             bool buvok = SvUOK(TOPs);
1651
1652             if (!auvok && !buvok) { /* ## IV <= IV ## */
1653                 IV aiv = SvIVX(TOPm1s);
1654                 IV biv = SvIVX(TOPs);
1655
1656                 SP--;
1657                 SETs(boolSV(aiv <= biv));
1658                 RETURN;
1659             }
1660             if (auvok && buvok) { /* ## UV <= UV ## */
1661                 UV auv = SvUVX(TOPm1s);
1662                 UV buv = SvUVX(TOPs);
1663
1664                 SP--;
1665                 SETs(boolSV(auv <= buv));
1666                 RETURN;
1667             }
1668             if (auvok) { /* ## UV <= IV ## */
1669                 UV auv;
1670                 IV biv;
1671
1672                 biv = SvIVX(TOPs);
1673                 SP--;
1674                 if (biv < 0) {
1675                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1676                     SETs(&PL_sv_no);
1677                     RETURN;
1678                 }
1679                 auv = SvUVX(TOPs);
1680                 SETs(boolSV(auv <= (UV)biv));
1681                 RETURN;
1682             }
1683             { /* ## IV <= UV ## */
1684                 IV aiv;
1685                 UV buv;
1686
1687                 aiv = SvIVX(TOPm1s);
1688                 if (aiv < 0) {
1689                     /* As (b) is a UV, it's >=0, so a must be <= */
1690                     SP--;
1691                     SETs(&PL_sv_yes);
1692                     RETURN;
1693                 }
1694                 buv = SvUVX(TOPs);
1695                 SP--;
1696                 SETs(boolSV((UV)aiv <= buv));
1697                 RETURN;
1698             }
1699         }
1700     }
1701 #endif
1702 #ifndef NV_PRESERVES_UV
1703 #ifdef PERL_PRESERVE_IVUV
1704     else
1705 #endif
1706         if (SvROK(TOPs) && SvROK(TOPm1s)) {
1707         SP--;
1708         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1709         RETURN;
1710     }
1711 #endif
1712     {
1713       dPOPnv;
1714       SETs(boolSV(TOPn <= value));
1715       RETURN;
1716     }
1717 }
1718
1719 PP(pp_ge)
1720 {
1721     dSP; tryAMAGICbinSET(ge,0);
1722 #ifdef PERL_PRESERVE_IVUV
1723     SvIV_please(TOPs);
1724     if (SvIOK(TOPs)) {
1725         SvIV_please(TOPm1s);
1726         if (SvIOK(TOPm1s)) {
1727             bool auvok = SvUOK(TOPm1s);
1728             bool buvok = SvUOK(TOPs);
1729
1730             if (!auvok && !buvok) { /* ## IV >= IV ## */
1731                 IV aiv = SvIVX(TOPm1s);
1732                 IV biv = SvIVX(TOPs);
1733
1734                 SP--;
1735                 SETs(boolSV(aiv >= biv));
1736                 RETURN;
1737             }
1738             if (auvok && buvok) { /* ## UV >= UV ## */
1739                 UV auv = SvUVX(TOPm1s);
1740                 UV buv = SvUVX(TOPs);
1741
1742                 SP--;
1743                 SETs(boolSV(auv >= buv));
1744                 RETURN;
1745             }
1746             if (auvok) { /* ## UV >= IV ## */
1747                 UV auv;
1748                 IV biv;
1749
1750                 biv = SvIVX(TOPs);
1751                 SP--;
1752                 if (biv < 0) {
1753                     /* As (a) is a UV, it's >=0, so it must be >= */
1754                     SETs(&PL_sv_yes);
1755                     RETURN;
1756                 }
1757                 auv = SvUVX(TOPs);
1758                 SETs(boolSV(auv >= (UV)biv));
1759                 RETURN;
1760             }
1761             { /* ## IV >= UV ## */
1762                 IV aiv;
1763                 UV buv;
1764
1765                 aiv = SvIVX(TOPm1s);
1766                 if (aiv < 0) {
1767                     /* As (b) is a UV, it's >=0, so a cannot be >= */
1768                     SP--;
1769                     SETs(&PL_sv_no);
1770                     RETURN;
1771                 }
1772                 buv = SvUVX(TOPs);
1773                 SP--;
1774                 SETs(boolSV((UV)aiv >= buv));
1775                 RETURN;
1776             }
1777         }
1778     }
1779 #endif
1780 #ifndef NV_PRESERVES_UV
1781 #ifdef PERL_PRESERVE_IVUV
1782     else
1783 #endif
1784         if (SvROK(TOPs) && SvROK(TOPm1s)) {
1785         SP--;
1786         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1787         RETURN;
1788     }
1789 #endif
1790     {
1791       dPOPnv;
1792       SETs(boolSV(TOPn >= value));
1793       RETURN;
1794     }
1795 }
1796
1797 PP(pp_ne)
1798 {
1799     dSP; tryAMAGICbinSET(ne,0);
1800 #ifndef NV_PRESERVES_UV
1801     if (SvROK(TOPs) && SvROK(TOPm1s)) {
1802         SP--;
1803         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1804         RETURN;
1805     }
1806 #endif
1807 #ifdef PERL_PRESERVE_IVUV
1808     SvIV_please(TOPs);
1809     if (SvIOK(TOPs)) {
1810         SvIV_please(TOPm1s);
1811         if (SvIOK(TOPm1s)) {
1812             bool auvok = SvUOK(TOPm1s);
1813             bool buvok = SvUOK(TOPs);
1814
1815             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1816                 /* Casting IV to UV before comparison isn't going to matter
1817                    on 2s complement. On 1s complement or sign&magnitude
1818                    (if we have any of them) it could make negative zero
1819                    differ from normal zero. As I understand it. (Need to
1820                    check - is negative zero implementation defined behaviour
1821                    anyway?). NWC  */
1822                 UV buv = SvUVX(POPs);
1823                 UV auv = SvUVX(TOPs);
1824
1825                 SETs(boolSV(auv != buv));
1826                 RETURN;
1827             }
1828             {                   /* ## Mixed IV,UV ## */
1829                 IV iv;
1830                 UV uv;
1831
1832                 /* != is commutative so swap if needed (save code) */
1833                 if (auvok) {
1834                     /* swap. top of stack (b) is the iv */
1835                     iv = SvIVX(TOPs);
1836                     SP--;
1837                     if (iv < 0) {
1838                         /* As (a) is a UV, it's >0, so it cannot be == */
1839                         SETs(&PL_sv_yes);
1840                         RETURN;
1841                     }
1842                     uv = SvUVX(TOPs);
1843                 } else {
1844                     iv = SvIVX(TOPm1s);
1845                     SP--;
1846                     if (iv < 0) {
1847                         /* As (b) is a UV, it's >0, so it cannot be == */
1848                         SETs(&PL_sv_yes);
1849                         RETURN;
1850                     }
1851                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1852                 }
1853                 SETs(boolSV((UV)iv != uv));
1854                 RETURN;
1855             }
1856         }
1857     }
1858 #endif
1859     {
1860       dPOPnv;
1861       SETs(boolSV(TOPn != value));
1862       RETURN;
1863     }
1864 }
1865
1866 PP(pp_ncmp)
1867 {
1868     dSP; dTARGET; tryAMAGICbin(ncmp,0);
1869 #ifndef NV_PRESERVES_UV
1870     if (SvROK(TOPs) && SvROK(TOPm1s)) {
1871         UV right = PTR2UV(SvRV(POPs));
1872         UV left = PTR2UV(SvRV(TOPs));
1873         SETi((left > right) - (left < right));
1874         RETURN;
1875     }
1876 #endif
1877 #ifdef PERL_PRESERVE_IVUV
1878     /* Fortunately it seems NaN isn't IOK */
1879     SvIV_please(TOPs);
1880     if (SvIOK(TOPs)) {
1881         SvIV_please(TOPm1s);
1882         if (SvIOK(TOPm1s)) {
1883             bool leftuvok = SvUOK(TOPm1s);
1884             bool rightuvok = SvUOK(TOPs);
1885             I32 value;
1886             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1887                 IV leftiv = SvIVX(TOPm1s);
1888                 IV rightiv = SvIVX(TOPs);
1889
1890                 if (leftiv > rightiv)
1891                     value = 1;
1892                 else if (leftiv < rightiv)
1893                     value = -1;
1894                 else
1895                     value = 0;
1896             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1897                 UV leftuv = SvUVX(TOPm1s);
1898                 UV rightuv = SvUVX(TOPs);
1899
1900                 if (leftuv > rightuv)
1901                     value = 1;
1902                 else if (leftuv < rightuv)
1903                     value = -1;
1904                 else
1905                     value = 0;
1906             } else if (leftuvok) { /* ## UV <=> IV ## */
1907                 UV leftuv;
1908                 IV rightiv;
1909
1910                 rightiv = SvIVX(TOPs);
1911                 if (rightiv < 0) {
1912                     /* As (a) is a UV, it's >=0, so it cannot be < */
1913                     value = 1;
1914                 } else {
1915                     leftuv = SvUVX(TOPm1s);
1916                     if (leftuv > (UV)rightiv) {
1917                         value = 1;
1918                     } else if (leftuv < (UV)rightiv) {
1919                         value = -1;
1920                     } else {
1921                         value = 0;
1922                     }
1923                 }
1924             } else { /* ## IV <=> UV ## */
1925                 IV leftiv;
1926                 UV rightuv;
1927
1928                 leftiv = SvIVX(TOPm1s);
1929                 if (leftiv < 0) {
1930                     /* As (b) is a UV, it's >=0, so it must be < */
1931                     value = -1;
1932                 } else {
1933                     rightuv = SvUVX(TOPs);
1934                     if ((UV)leftiv > rightuv) {
1935                         value = 1;
1936                     } else if ((UV)leftiv < rightuv) {
1937                         value = -1;
1938                     } else {
1939                         value = 0;
1940                     }
1941                 }
1942             }
1943             SP--;
1944             SETi(value);
1945             RETURN;
1946         }
1947     }
1948 #endif
1949     {
1950       dPOPTOPnnrl;
1951       I32 value;
1952
1953 #ifdef Perl_isnan
1954       if (Perl_isnan(left) || Perl_isnan(right)) {
1955           SETs(&PL_sv_undef);
1956           RETURN;
1957        }
1958       value = (left > right) - (left < right);
1959 #else
1960       if (left == right)
1961         value = 0;
1962       else if (left < right)
1963         value = -1;
1964       else if (left > right)
1965         value = 1;
1966       else {
1967         SETs(&PL_sv_undef);
1968         RETURN;
1969       }
1970 #endif
1971       SETi(value);
1972       RETURN;
1973     }
1974 }
1975
1976 PP(pp_slt)
1977 {
1978     dSP; tryAMAGICbinSET(slt,0);
1979     {
1980       dPOPTOPssrl;
1981       int cmp = (IN_LOCALE_RUNTIME
1982                  ? sv_cmp_locale(left, right)
1983                  : sv_cmp(left, right));
1984       SETs(boolSV(cmp < 0));
1985       RETURN;
1986     }
1987 }
1988
1989 PP(pp_sgt)
1990 {
1991     dSP; tryAMAGICbinSET(sgt,0);
1992     {
1993       dPOPTOPssrl;
1994       int cmp = (IN_LOCALE_RUNTIME
1995                  ? sv_cmp_locale(left, right)
1996                  : sv_cmp(left, right));
1997       SETs(boolSV(cmp > 0));
1998       RETURN;
1999     }
2000 }
2001
2002 PP(pp_sle)
2003 {
2004     dSP; tryAMAGICbinSET(sle,0);
2005     {
2006       dPOPTOPssrl;
2007       int cmp = (IN_LOCALE_RUNTIME
2008                  ? sv_cmp_locale(left, right)
2009                  : sv_cmp(left, right));
2010       SETs(boolSV(cmp <= 0));
2011       RETURN;
2012     }
2013 }
2014
2015 PP(pp_sge)
2016 {
2017     dSP; tryAMAGICbinSET(sge,0);
2018     {
2019       dPOPTOPssrl;
2020       int cmp = (IN_LOCALE_RUNTIME
2021                  ? sv_cmp_locale(left, right)
2022                  : sv_cmp(left, right));
2023       SETs(boolSV(cmp >= 0));
2024       RETURN;
2025     }
2026 }
2027
2028 PP(pp_seq)
2029 {
2030     dSP; tryAMAGICbinSET(seq,0);
2031     {
2032       dPOPTOPssrl;
2033       SETs(boolSV(sv_eq(left, right)));
2034       RETURN;
2035     }
2036 }
2037
2038 PP(pp_sne)
2039 {
2040     dSP; tryAMAGICbinSET(sne,0);
2041     {
2042       dPOPTOPssrl;
2043       SETs(boolSV(!sv_eq(left, right)));
2044       RETURN;
2045     }
2046 }
2047
2048 PP(pp_scmp)
2049 {
2050     dSP; dTARGET;  tryAMAGICbin(scmp,0);
2051     {
2052       dPOPTOPssrl;
2053       int cmp = (IN_LOCALE_RUNTIME
2054                  ? sv_cmp_locale(left, right)
2055                  : sv_cmp(left, right));
2056       SETi( cmp );
2057       RETURN;
2058     }
2059 }
2060
2061 PP(pp_bit_and)
2062 {
2063     dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2064     {
2065       dPOPTOPssrl;
2066       if (SvNIOKp(left) || SvNIOKp(right)) {
2067         if (PL_op->op_private & HINT_INTEGER) {
2068           IV i = SvIV(left) & SvIV(right);
2069           SETi(i);
2070         }
2071         else {
2072           UV u = SvUV(left) & SvUV(right);
2073           SETu(u);
2074         }
2075       }
2076       else {
2077         do_vop(PL_op->op_type, TARG, left, right);
2078         SETTARG;
2079       }
2080       RETURN;
2081     }
2082 }
2083
2084 PP(pp_bit_xor)
2085 {
2086     dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2087     {
2088       dPOPTOPssrl;
2089       if (SvNIOKp(left) || SvNIOKp(right)) {
2090         if (PL_op->op_private & HINT_INTEGER) {
2091           IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2092           SETi(i);
2093         }
2094         else {
2095           UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2096           SETu(u);
2097         }
2098       }
2099       else {
2100         do_vop(PL_op->op_type, TARG, left, right);
2101         SETTARG;
2102       }
2103       RETURN;
2104     }
2105 }
2106
2107 PP(pp_bit_or)
2108 {
2109     dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2110     {
2111       dPOPTOPssrl;
2112       if (SvNIOKp(left) || SvNIOKp(right)) {
2113         if (PL_op->op_private & HINT_INTEGER) {
2114           IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2115           SETi(i);
2116         }
2117         else {
2118           UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2119           SETu(u);
2120         }
2121       }
2122       else {
2123         do_vop(PL_op->op_type, TARG, left, right);
2124         SETTARG;
2125       }
2126       RETURN;
2127     }
2128 }
2129
2130 PP(pp_negate)
2131 {
2132     dSP; dTARGET; tryAMAGICun(neg);
2133     {
2134         dTOPss;
2135         int flags = SvFLAGS(sv);
2136         if (SvGMAGICAL(sv))
2137             mg_get(sv);
2138         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2139             /* It's publicly an integer, or privately an integer-not-float */
2140         oops_its_an_int:
2141             if (SvIsUV(sv)) {
2142                 if (SvIVX(sv) == IV_MIN) {
2143                     /* 2s complement assumption. */
2144                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2145                     RETURN;
2146                 }
2147                 else if (SvUVX(sv) <= IV_MAX) {
2148                     SETi(-SvIVX(sv));
2149                     RETURN;
2150                 }
2151             }
2152             else if (SvIVX(sv) != IV_MIN) {
2153                 SETi(-SvIVX(sv));
2154                 RETURN;
2155             }
2156 #ifdef PERL_PRESERVE_IVUV
2157             else {
2158                 SETu((UV)IV_MIN);
2159                 RETURN;
2160             }
2161 #endif
2162         }
2163         if (SvNIOKp(sv))
2164             SETn(-SvNV(sv));
2165         else if (SvPOKp(sv)) {
2166             STRLEN len;
2167             char *s = SvPV(sv, len);
2168             if (isIDFIRST(*s)) {
2169                 sv_setpvn(TARG, "-", 1);
2170                 sv_catsv(TARG, sv);
2171             }
2172             else if (*s == '+' || *s == '-') {
2173                 sv_setsv(TARG, sv);
2174                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2175             }
2176             else if (DO_UTF8(sv)) {
2177                 SvIV_please(sv);
2178                 if (SvIOK(sv))
2179                     goto oops_its_an_int;
2180                 if (SvNOK(sv))
2181                     sv_setnv(TARG, -SvNV(sv));
2182                 else {
2183                     sv_setpvn(TARG, "-", 1);
2184                     sv_catsv(TARG, sv);
2185                 }
2186             }
2187             else {
2188                 SvIV_please(sv);
2189                 if (SvIOK(sv))
2190                   goto oops_its_an_int;
2191                 sv_setnv(TARG, -SvNV(sv));
2192             }
2193             SETTARG;
2194         }
2195         else
2196             SETn(-SvNV(sv));
2197     }
2198     RETURN;
2199 }
2200
2201 PP(pp_not)
2202 {
2203     dSP; tryAMAGICunSET(not);
2204     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2205     return NORMAL;
2206 }
2207
2208 PP(pp_complement)
2209 {
2210     dSP; dTARGET; tryAMAGICun(compl);
2211     {
2212       dTOPss;
2213       if (SvNIOKp(sv)) {
2214         if (PL_op->op_private & HINT_INTEGER) {
2215           IV i = ~SvIV(sv);
2216           SETi(i);
2217         }
2218         else {
2219           UV u = ~SvUV(sv);
2220           SETu(u);
2221         }
2222       }
2223       else {
2224         register U8 *tmps;
2225         register I32 anum;
2226         STRLEN len;
2227
2228         SvSetSV(TARG, sv);
2229         tmps = (U8*)SvPV_force(TARG, len);
2230         anum = len;
2231         if (SvUTF8(TARG)) {
2232           /* Calculate exact length, let's not estimate. */
2233           STRLEN targlen = 0;
2234           U8 *result;
2235           U8 *send;
2236           STRLEN l;
2237           UV nchar = 0;
2238           UV nwide = 0;
2239
2240           send = tmps + len;
2241           while (tmps < send) {
2242             UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2243             tmps += UTF8SKIP(tmps);
2244             targlen += UNISKIP(~c);
2245             nchar++;
2246             if (c > 0xff)
2247                 nwide++;
2248           }
2249
2250           /* Now rewind strings and write them. */
2251           tmps -= len;
2252
2253           if (nwide) {
2254               Newz(0, result, targlen + 1, U8);
2255               while (tmps < send) {
2256                   UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2257                   tmps += UTF8SKIP(tmps);
2258                   result = uvchr_to_utf8(result, ~c);
2259               }
2260               *result = '\0';
2261               result -= targlen;
2262               sv_setpvn(TARG, (char*)result, targlen);
2263               SvUTF8_on(TARG);
2264           }
2265           else {
2266               Newz(0, result, nchar + 1, U8);
2267               while (tmps < send) {
2268                   U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2269                   tmps += UTF8SKIP(tmps);
2270                   *result++ = ~c;
2271               }
2272               *result = '\0';
2273               result -= nchar;
2274               sv_setpvn(TARG, (char*)result, nchar);
2275           }
2276           Safefree(result);
2277           SETs(TARG);
2278           RETURN;
2279         }
2280 #ifdef LIBERAL
2281         {
2282             register long *tmpl;
2283             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2284                 *tmps = ~*tmps;
2285             tmpl = (long*)tmps;
2286             for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2287                 *tmpl = ~*tmpl;
2288             tmps = (U8*)tmpl;
2289         }
2290 #endif
2291         for ( ; anum > 0; anum--, tmps++)
2292             *tmps = ~*tmps;
2293
2294         SETs(TARG);
2295       }
2296       RETURN;
2297     }
2298 }
2299
2300 /* integer versions of some of the above */
2301
2302 PP(pp_i_multiply)
2303 {
2304     dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2305     {
2306       dPOPTOPiirl;
2307       SETi( left * right );
2308       RETURN;
2309     }
2310 }
2311
2312 PP(pp_i_divide)
2313 {
2314     dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2315     {
2316       dPOPiv;
2317       if (value == 0)
2318         DIE(aTHX_ "Illegal division by zero");
2319       value = POPi / value;
2320       PUSHi( value );
2321       RETURN;
2322     }
2323 }
2324
2325 PP(pp_i_modulo)
2326 {
2327     dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2328     {
2329       dPOPTOPiirl;
2330       if (!right)
2331         DIE(aTHX_ "Illegal modulus zero");
2332       SETi( left % right );
2333       RETURN;
2334     }
2335 }
2336
2337 PP(pp_i_add)
2338 {
2339     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2340     {
2341       dPOPTOPiirl_ul;
2342       SETi( left + right );
2343       RETURN;
2344     }
2345 }
2346
2347 PP(pp_i_subtract)
2348 {
2349     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2350     {
2351       dPOPTOPiirl_ul;
2352       SETi( left - right );
2353       RETURN;
2354     }
2355 }
2356
2357 PP(pp_i_lt)
2358 {
2359     dSP; tryAMAGICbinSET(lt,0);
2360     {
2361       dPOPTOPiirl;
2362       SETs(boolSV(left < right));
2363       RETURN;
2364     }
2365 }
2366
2367 PP(pp_i_gt)
2368 {
2369     dSP; tryAMAGICbinSET(gt,0);
2370     {
2371       dPOPTOPiirl;
2372       SETs(boolSV(left > right));
2373       RETURN;
2374     }
2375 }
2376
2377 PP(pp_i_le)
2378 {
2379     dSP; tryAMAGICbinSET(le,0);
2380     {
2381       dPOPTOPiirl;
2382       SETs(boolSV(left <= right));
2383       RETURN;
2384     }
2385 }
2386
2387 PP(pp_i_ge)
2388 {
2389     dSP; tryAMAGICbinSET(ge,0);
2390     {
2391       dPOPTOPiirl;
2392       SETs(boolSV(left >= right));
2393       RETURN;
2394     }
2395 }
2396
2397 PP(pp_i_eq)
2398 {
2399     dSP; tryAMAGICbinSET(eq,0);
2400     {
2401       dPOPTOPiirl;
2402       SETs(boolSV(left == right));
2403       RETURN;
2404     }
2405 }
2406
2407 PP(pp_i_ne)
2408 {
2409     dSP; tryAMAGICbinSET(ne,0);
2410     {
2411       dPOPTOPiirl;
2412       SETs(boolSV(left != right));
2413       RETURN;
2414     }
2415 }
2416
2417 PP(pp_i_ncmp)
2418 {
2419     dSP; dTARGET; tryAMAGICbin(ncmp,0);
2420     {
2421       dPOPTOPiirl;
2422       I32 value;
2423
2424       if (left > right)
2425         value = 1;
2426       else if (left < right)
2427         value = -1;
2428       else
2429         value = 0;
2430       SETi(value);
2431       RETURN;
2432     }
2433 }
2434
2435 PP(pp_i_negate)
2436 {
2437     dSP; dTARGET; tryAMAGICun(neg);
2438     SETi(-TOPi);
2439     RETURN;
2440 }
2441
2442 /* High falutin' math. */
2443
2444 PP(pp_atan2)
2445 {
2446     dSP; dTARGET; tryAMAGICbin(atan2,0);
2447     {
2448       dPOPTOPnnrl;
2449       SETn(Perl_atan2(left, right));
2450       RETURN;
2451     }
2452 }
2453
2454 PP(pp_sin)
2455 {
2456     dSP; dTARGET; tryAMAGICun(sin);
2457     {
2458       NV value;
2459       value = POPn;
2460       value = Perl_sin(value);
2461       XPUSHn(value);
2462       RETURN;
2463     }
2464 }
2465
2466 PP(pp_cos)
2467 {
2468     dSP; dTARGET; tryAMAGICun(cos);
2469     {
2470       NV value;
2471       value = POPn;
2472       value = Perl_cos(value);
2473       XPUSHn(value);
2474       RETURN;
2475     }
2476 }
2477
2478 /* Support Configure command-line overrides for rand() functions.
2479    After 5.005, perhaps we should replace this by Configure support
2480    for drand48(), random(), or rand().  For 5.005, though, maintain
2481    compatibility by calling rand() but allow the user to override it.
2482    See INSTALL for details.  --Andy Dougherty  15 July 1998
2483 */
2484 /* Now it's after 5.005, and Configure supports drand48() and random(),
2485    in addition to rand().  So the overrides should not be needed any more.
2486    --Jarkko Hietaniemi  27 September 1998
2487  */
2488
2489 #ifndef HAS_DRAND48_PROTO
2490 extern double drand48 (void);
2491 #endif
2492
2493 PP(pp_rand)
2494 {
2495     dSP; dTARGET;
2496     NV value;
2497     if (MAXARG < 1)
2498         value = 1.0;
2499     else
2500         value = POPn;
2501     if (value == 0.0)
2502         value = 1.0;
2503     if (!PL_srand_called) {
2504         (void)seedDrand01((Rand_seed_t)seed());
2505         PL_srand_called = TRUE;
2506     }
2507     value *= Drand01();
2508     XPUSHn(value);
2509     RETURN;
2510 }
2511
2512 PP(pp_srand)
2513 {
2514     dSP;
2515     UV anum;
2516     if (MAXARG < 1)
2517         anum = seed();
2518     else
2519         anum = POPu;
2520     (void)seedDrand01((Rand_seed_t)anum);
2521     PL_srand_called = TRUE;
2522     EXTEND(SP, 1);
2523     RETPUSHYES;
2524 }
2525
2526 STATIC U32
2527 S_seed(pTHX)
2528 {
2529     /*
2530      * This is really just a quick hack which grabs various garbage
2531      * values.  It really should be a real hash algorithm which
2532      * spreads the effect of every input bit onto every output bit,
2533      * if someone who knows about such things would bother to write it.
2534      * Might be a good idea to add that function to CORE as well.
2535      * No numbers below come from careful analysis or anything here,
2536      * except they are primes and SEED_C1 > 1E6 to get a full-width
2537      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
2538      * probably be bigger too.
2539      */
2540 #if RANDBITS > 16
2541 #  define SEED_C1       1000003
2542 #define   SEED_C4       73819
2543 #else
2544 #  define SEED_C1       25747
2545 #define   SEED_C4       20639
2546 #endif
2547 #define   SEED_C2       3
2548 #define   SEED_C3       269
2549 #define   SEED_C5       26107
2550
2551 #ifndef PERL_NO_DEV_RANDOM
2552     int fd;
2553 #endif
2554     U32 u;
2555 #ifdef VMS
2556 #  include <starlet.h>
2557     /* when[] = (low 32 bits, high 32 bits) of time since epoch
2558      * in 100-ns units, typically incremented ever 10 ms.        */
2559     unsigned int when[2];
2560 #else
2561 #  ifdef HAS_GETTIMEOFDAY
2562     struct timeval when;
2563 #  else
2564     Time_t when;
2565 #  endif
2566 #endif
2567
2568 /* This test is an escape hatch, this symbol isn't set by Configure. */
2569 #ifndef PERL_NO_DEV_RANDOM
2570 #ifndef PERL_RANDOM_DEVICE
2571    /* /dev/random isn't used by default because reads from it will block
2572     * if there isn't enough entropy available.  You can compile with
2573     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2574     * is enough real entropy to fill the seed. */
2575 #  define PERL_RANDOM_DEVICE "/dev/urandom"
2576 #endif
2577     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2578     if (fd != -1) {
2579         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2580             u = 0;
2581         PerlLIO_close(fd);
2582         if (u)
2583             return u;
2584     }
2585 #endif
2586
2587 #ifdef VMS
2588     _ckvmssts(sys$gettim(when));
2589     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2590 #else
2591 #  ifdef HAS_GETTIMEOFDAY
2592     gettimeofday(&when,(struct timezone *) 0);
2593     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2594 #  else
2595     (void)time(&when);
2596     u = (U32)SEED_C1 * when;
2597 #  endif
2598 #endif
2599     u += SEED_C3 * (U32)PerlProc_getpid();
2600     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2601 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
2602     u += SEED_C5 * (U32)PTR2UV(&when);
2603 #endif
2604     return u;
2605 }
2606
2607 PP(pp_exp)
2608 {
2609     dSP; dTARGET; tryAMAGICun(exp);
2610     {
2611       NV value;
2612       value = POPn;
2613       value = Perl_exp(value);
2614       XPUSHn(value);
2615       RETURN;
2616     }
2617 }
2618
2619 PP(pp_log)
2620 {
2621     dSP; dTARGET; tryAMAGICun(log);
2622     {
2623       NV value;
2624       value = POPn;
2625       if (value <= 0.0) {
2626         SET_NUMERIC_STANDARD();
2627         DIE(aTHX_ "Can't take log of %g", value);
2628       }
2629       value = Perl_log(value);
2630       XPUSHn(value);
2631       RETURN;
2632     }
2633 }
2634
2635 PP(pp_sqrt)
2636 {
2637     dSP; dTARGET; tryAMAGICun(sqrt);
2638     {
2639       NV value;
2640       value = POPn;
2641       if (value < 0.0) {
2642         SET_NUMERIC_STANDARD();
2643         DIE(aTHX_ "Can't take sqrt of %g", value);
2644       }
2645       value = Perl_sqrt(value);
2646       XPUSHn(value);
2647       RETURN;
2648     }
2649 }
2650
2651 PP(pp_int)
2652 {
2653     dSP; dTARGET; tryAMAGICun(int);
2654     {
2655       NV value;
2656       IV iv = TOPi; /* attempt to convert to IV if possible. */
2657       /* XXX it's arguable that compiler casting to IV might be subtly
2658          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2659          else preferring IV has introduced a subtle behaviour change bug. OTOH
2660          relying on floating point to be accurate is a bug.  */
2661
2662       if (SvIOK(TOPs)) {
2663         if (SvIsUV(TOPs)) {
2664             UV uv = TOPu;
2665             SETu(uv);
2666         } else
2667             SETi(iv);
2668       } else {
2669           value = TOPn;
2670           if (value >= 0.0) {
2671               if (value < (NV)UV_MAX + 0.5) {
2672                   SETu(U_V(value));
2673               } else {
2674 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2675 #   ifdef HAS_MODFL_POW32_BUG
2676 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2677                 {
2678                     NV offset = Perl_modf(value, &value);
2679                     (void)Perl_modf(offset, &offset);
2680                     value += offset;
2681                 }
2682 #   else
2683                   (void)Perl_modf(value, &value);
2684 #   endif
2685 #else
2686                   double tmp = (double)value;
2687                   (void)Perl_modf(tmp, &tmp);
2688                   value = (NV)tmp;
2689 #endif
2690                   SETn(value);
2691               }
2692           }
2693           else {
2694               if (value > (NV)IV_MIN - 0.5) {
2695                   SETi(I_V(value));
2696               } else {
2697 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2698 #   ifdef HAS_MODFL_POW32_BUG
2699 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2700                  {
2701                      NV offset = Perl_modf(-value, &value);
2702                      (void)Perl_modf(offset, &offset);
2703                      value += offset;
2704                  }
2705 #   else
2706                   (void)Perl_modf(-value, &value);
2707 #   endif
2708                   value = -value;
2709 #else
2710                   double tmp = (double)value;
2711                   (void)Perl_modf(-tmp, &tmp);
2712                   value = -(NV)tmp;
2713 #endif
2714                   SETn(value);
2715               }
2716           }
2717       }
2718     }
2719     RETURN;
2720 }
2721
2722 PP(pp_abs)
2723 {
2724     dSP; dTARGET; tryAMAGICun(abs);
2725     {
2726       /* This will cache the NV value if string isn't actually integer  */
2727       IV iv = TOPi;
2728
2729       if (SvIOK(TOPs)) {
2730         /* IVX is precise  */
2731         if (SvIsUV(TOPs)) {
2732           SETu(TOPu);   /* force it to be numeric only */
2733         } else {
2734           if (iv >= 0) {
2735             SETi(iv);
2736           } else {
2737             if (iv != IV_MIN) {
2738               SETi(-iv);
2739             } else {
2740               /* 2s complement assumption. Also, not really needed as
2741                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2742               SETu(IV_MIN);
2743             }
2744           }
2745         }
2746       } else{
2747         NV value = TOPn;
2748         if (value < 0.0)
2749           value = -value;
2750         SETn(value);
2751       }
2752     }
2753     RETURN;
2754 }
2755
2756
2757 PP(pp_hex)
2758 {
2759     dSP; dTARGET;
2760     char *tmps;
2761     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2762     STRLEN len;
2763     NV result_nv;
2764     UV result_uv;
2765
2766     tmps = (SvPVx(POPs, len));
2767     result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2768     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2769         XPUSHn(result_nv);
2770     }
2771     else {
2772         XPUSHu(result_uv);
2773     }
2774     RETURN;
2775 }
2776
2777 PP(pp_oct)
2778 {
2779     dSP; dTARGET;
2780     char *tmps;
2781     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2782     STRLEN len;
2783     NV result_nv;
2784     UV result_uv;
2785
2786     tmps = (SvPVx(POPs, len));
2787     while (*tmps && len && isSPACE(*tmps))
2788         tmps++, len--;
2789     if (*tmps == '0')
2790         tmps++, len--;
2791     if (*tmps == 'x')
2792         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2793     else if (*tmps == 'b')
2794         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2795     else
2796         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2797
2798     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2799         XPUSHn(result_nv);
2800     }
2801     else {
2802         XPUSHu(result_uv);
2803     }
2804     RETURN;
2805 }
2806
2807 /* String stuff. */
2808
2809 PP(pp_length)
2810 {
2811     dSP; dTARGET;
2812     SV *sv = TOPs;
2813
2814     if (DO_UTF8(sv))
2815         SETi(sv_len_utf8(sv));
2816     else
2817         SETi(sv_len(sv));
2818     RETURN;
2819 }
2820
2821 PP(pp_substr)
2822 {
2823     dSP; dTARGET;
2824     SV *sv;
2825     I32 len = 0;
2826     STRLEN curlen;
2827     STRLEN utf8_curlen;
2828     I32 pos;
2829     I32 rem;
2830     I32 fail;
2831     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2832     char *tmps;
2833     I32 arybase = PL_curcop->cop_arybase;
2834     SV *repl_sv = NULL;
2835     char *repl = 0;
2836     STRLEN repl_len;
2837     int num_args = PL_op->op_private & 7;
2838     bool repl_need_utf8_upgrade = FALSE;
2839     bool repl_is_utf8 = FALSE;
2840
2841     SvTAINTED_off(TARG);                        /* decontaminate */
2842     SvUTF8_off(TARG);                           /* decontaminate */
2843     if (num_args > 2) {
2844         if (num_args > 3) {
2845             repl_sv = POPs;
2846             repl = SvPV(repl_sv, repl_len);
2847             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2848         }
2849         len = POPi;
2850     }
2851     pos = POPi;
2852     sv = POPs;
2853     PUTBACK;
2854     if (repl_sv) {
2855         if (repl_is_utf8) {
2856             if (!DO_UTF8(sv))
2857                 sv_utf8_upgrade(sv);
2858         }
2859         else if (DO_UTF8(sv))
2860             repl_need_utf8_upgrade = TRUE;
2861     }
2862     tmps = SvPV(sv, curlen);
2863     if (DO_UTF8(sv)) {
2864         utf8_curlen = sv_len_utf8(sv);
2865         if (utf8_curlen == curlen)
2866             utf8_curlen = 0;
2867         else
2868             curlen = utf8_curlen;
2869     }
2870     else
2871         utf8_curlen = 0;
2872
2873     if (pos >= arybase) {
2874         pos -= arybase;
2875         rem = curlen-pos;
2876         fail = rem;
2877         if (num_args > 2) {
2878             if (len < 0) {
2879                 rem += len;
2880                 if (rem < 0)
2881                     rem = 0;
2882             }
2883             else if (rem > len)
2884                      rem = len;
2885         }
2886     }
2887     else {
2888         pos += curlen;
2889         if (num_args < 3)
2890             rem = curlen;
2891         else if (len >= 0) {
2892             rem = pos+len;
2893             if (rem > (I32)curlen)
2894                 rem = curlen;
2895         }
2896         else {
2897             rem = curlen+len;
2898             if (rem < pos)
2899                 rem = pos;
2900         }
2901         if (pos < 0)
2902             pos = 0;
2903         fail = rem;
2904         rem -= pos;
2905     }
2906     if (fail < 0) {
2907         if (lvalue || repl)
2908             Perl_croak(aTHX_ "substr outside of string");
2909         if (ckWARN(WARN_SUBSTR))
2910             Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2911         RETPUSHUNDEF;
2912     }
2913     else {
2914         I32 upos = pos;
2915         I32 urem = rem;
2916         if (utf8_curlen)
2917             sv_pos_u2b(sv, &pos, &rem);
2918         tmps += pos;
2919         sv_setpvn(TARG, tmps, rem);
2920 #ifdef USE_LOCALE_COLLATE
2921         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2922 #endif
2923         if (utf8_curlen)
2924             SvUTF8_on(TARG);
2925         if (repl) {
2926             SV* repl_sv_copy = NULL;
2927
2928             if (repl_need_utf8_upgrade) {
2929                 repl_sv_copy = newSVsv(repl_sv);
2930                 sv_utf8_upgrade(repl_sv_copy);
2931                 repl = SvPV(repl_sv_copy, repl_len);
2932                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2933             }
2934             sv_insert(sv, pos, rem, repl, repl_len);
2935             if (repl_is_utf8)
2936                 SvUTF8_on(sv);
2937             if (repl_sv_copy)
2938                 SvREFCNT_dec(repl_sv_copy);
2939         }
2940         else if (lvalue) {              /* it's an lvalue! */
2941             if (!SvGMAGICAL(sv)) {
2942                 if (SvROK(sv)) {
2943                     STRLEN n_a;
2944                     SvPV_force(sv,n_a);
2945                     if (ckWARN(WARN_SUBSTR))
2946                         Perl_warner(aTHX_ WARN_SUBSTR,
2947                                 "Attempt to use reference as lvalue in substr");
2948                 }
2949                 if (SvOK(sv))           /* is it defined ? */
2950                     (void)SvPOK_only_UTF8(sv);
2951                 else
2952                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2953             }
2954
2955             if (SvTYPE(TARG) < SVt_PVLV) {
2956                 sv_upgrade(TARG, SVt_PVLV);
2957                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2958             }
2959
2960             LvTYPE(TARG) = 'x';
2961             if (LvTARG(TARG) != sv) {
2962                 if (LvTARG(TARG))
2963                     SvREFCNT_dec(LvTARG(TARG));
2964                 LvTARG(TARG) = SvREFCNT_inc(sv);
2965             }
2966             LvTARGOFF(TARG) = upos;
2967             LvTARGLEN(TARG) = urem;
2968         }
2969     }
2970     SPAGAIN;
2971     PUSHs(TARG);                /* avoid SvSETMAGIC here */
2972     RETURN;
2973 }
2974
2975 PP(pp_vec)
2976 {
2977     dSP; dTARGET;
2978     register IV size   = POPi;
2979     register IV offset = POPi;
2980     register SV *src = POPs;
2981     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2982
2983     SvTAINTED_off(TARG);                /* decontaminate */
2984     if (lvalue) {                       /* it's an lvalue! */
2985         if (SvTYPE(TARG) < SVt_PVLV) {
2986             sv_upgrade(TARG, SVt_PVLV);
2987             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2988         }
2989         LvTYPE(TARG) = 'v';
2990         if (LvTARG(TARG) != src) {
2991             if (LvTARG(TARG))
2992                 SvREFCNT_dec(LvTARG(TARG));
2993             LvTARG(TARG) = SvREFCNT_inc(src);
2994         }
2995         LvTARGOFF(TARG) = offset;
2996         LvTARGLEN(TARG) = size;
2997     }
2998
2999     sv_setuv(TARG, do_vecget(src, offset, size));
3000     PUSHs(TARG);
3001     RETURN;
3002 }
3003
3004 PP(pp_index)
3005 {
3006     dSP; dTARGET;
3007     SV *big;
3008     SV *little;
3009     I32 offset;
3010     I32 retval;
3011     char *tmps;
3012     char *tmps2;
3013     STRLEN biglen;
3014     I32 arybase = PL_curcop->cop_arybase;
3015
3016     if (MAXARG < 3)
3017         offset = 0;
3018     else
3019         offset = POPi - arybase;
3020     little = POPs;
3021     big = POPs;
3022     tmps = SvPV(big, biglen);
3023     if (offset > 0 && DO_UTF8(big))
3024         sv_pos_u2b(big, &offset, 0);
3025     if (offset < 0)
3026         offset = 0;
3027     else if (offset > biglen)
3028         offset = biglen;
3029     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3030       (unsigned char*)tmps + biglen, little, 0)))
3031         retval = -1;
3032     else
3033         retval = tmps2 - tmps;
3034     if (retval > 0 && DO_UTF8(big))
3035         sv_pos_b2u(big, &retval);
3036     PUSHi(retval + arybase);
3037     RETURN;
3038 }
3039
3040 PP(pp_rindex)
3041 {
3042     dSP; dTARGET;
3043     SV *big;
3044     SV *little;
3045     STRLEN blen;
3046     STRLEN llen;
3047     I32 offset;
3048     I32 retval;
3049     char *tmps;
3050     char *tmps2;
3051     I32 arybase = PL_curcop->cop_arybase;
3052
3053     if (MAXARG >= 3)
3054         offset = POPi;
3055     little = POPs;
3056     big = POPs;
3057     tmps2 = SvPV(little, llen);
3058     tmps = SvPV(big, blen);
3059     if (MAXARG < 3)
3060         offset = blen;
3061     else {
3062         if (offset > 0 && DO_UTF8(big))
3063             sv_pos_u2b(big, &offset, 0);
3064         offset = offset - arybase + llen;
3065     }
3066     if (offset < 0)
3067         offset = 0;
3068     else if (offset > blen)
3069         offset = blen;
3070     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3071                           tmps2, tmps2 + llen)))
3072         retval = -1;
3073     else
3074         retval = tmps2 - tmps;
3075     if (retval > 0 && DO_UTF8(big))
3076         sv_pos_b2u(big, &retval);
3077     PUSHi(retval + arybase);
3078     RETURN;
3079 }
3080
3081 PP(pp_sprintf)
3082 {
3083     dSP; dMARK; dORIGMARK; dTARGET;
3084     do_sprintf(TARG, SP-MARK, MARK+1);
3085     TAINT_IF(SvTAINTED(TARG));
3086     if (DO_UTF8(*(MARK+1)))
3087         SvUTF8_on(TARG);
3088     SP = ORIGMARK;
3089     PUSHTARG;
3090     RETURN;
3091 }
3092
3093 PP(pp_ord)
3094 {
3095     dSP; dTARGET;
3096     SV *argsv = POPs;
3097     STRLEN len;
3098     U8 *s = (U8*)SvPVx(argsv, len);
3099     SV *tmpsv;
3100
3101     if (PL_encoding && !DO_UTF8(argsv)) {
3102         tmpsv = sv_2mortal(newSVsv(argsv));
3103         s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
3104         argsv = tmpsv;
3105     }
3106
3107     XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3108
3109     RETURN;
3110 }
3111
3112 PP(pp_chr)
3113 {
3114     dSP; dTARGET;
3115     char *tmps;
3116     UV value = POPu;
3117
3118     (void)SvUPGRADE(TARG,SVt_PV);
3119
3120     if (value > 255 && !IN_BYTES) {
3121         SvGROW(TARG, UNISKIP(value)+1);
3122         tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3123         SvCUR_set(TARG, tmps - SvPVX(TARG));
3124         *tmps = '\0';
3125         (void)SvPOK_only(TARG);
3126         SvUTF8_on(TARG);
3127         XPUSHs(TARG);
3128         RETURN;
3129     }
3130
3131     SvGROW(TARG,2);
3132     SvCUR_set(TARG, 1);
3133     tmps = SvPVX(TARG);
3134     *tmps++ = value;
3135     *tmps = '\0';
3136     (void)SvPOK_only(TARG);
3137     if (PL_encoding)
3138         Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3139     XPUSHs(TARG);
3140     RETURN;
3141 }
3142
3143 PP(pp_crypt)
3144 {
3145     dSP; dTARGET; dPOPTOPssrl;
3146     STRLEN n_a;
3147 #ifdef HAS_CRYPT
3148     STRLEN len;
3149     char *tmps = SvPV(left, len);
3150     char *t    = 0;
3151     if (DO_UTF8(left)) {
3152          /* If Unicode take the crypt() of the low 8 bits
3153           * of the characters of the string. */
3154          char *s    = tmps;
3155          char *send = tmps + len;
3156          STRLEN i   = 0;
3157          Newz(688, t, len, char);
3158          while (s < send) {
3159               t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3160               s += UTF8SKIP(s);
3161          }
3162          tmps = t;
3163     }
3164 #ifdef FCRYPT
3165     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3166 #else
3167     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3168 #endif
3169     Safefree(t);
3170 #else
3171     DIE(aTHX_
3172       "The crypt() function is unimplemented due to excessive paranoia.");
3173 #endif
3174     SETs(TARG);
3175     RETURN;
3176 }
3177
3178 PP(pp_ucfirst)
3179 {
3180     dSP;
3181     SV *sv = TOPs;
3182     register U8 *s;
3183     STRLEN slen;
3184
3185     if (DO_UTF8(sv)) {
3186         U8 tmpbuf[UTF8_MAXLEN*2+1];
3187         STRLEN ulen;
3188         STRLEN tculen;
3189
3190         s = (U8*)SvPV(sv, slen);
3191         utf8_to_uvchr(s, &ulen);
3192
3193         toTITLE_utf8(s, tmpbuf, &tculen);
3194         utf8_to_uvchr(tmpbuf, 0);
3195
3196         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3197             dTARGET;
3198             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3199             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3200             SvUTF8_on(TARG);
3201             SETs(TARG);
3202         }
3203         else {
3204             s = (U8*)SvPV_force(sv, slen);
3205             Copy(tmpbuf, s, tculen, U8);
3206         }
3207     }
3208     else {
3209         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3210             dTARGET;
3211             SvUTF8_off(TARG);                           /* decontaminate */
3212             sv_setsv(TARG, sv);
3213             sv = TARG;
3214             SETs(sv);
3215         }
3216         s = (U8*)SvPV_force(sv, slen);
3217         if (*s) {
3218             if (IN_LOCALE_RUNTIME) {
3219                 TAINT;
3220                 SvTAINTED_on(sv);
3221                 *s = toUPPER_LC(*s);
3222             }
3223             else
3224                 *s = toUPPER(*s);
3225         }
3226     }
3227     if (SvSMAGICAL(sv))
3228         mg_set(sv);
3229     RETURN;
3230 }
3231
3232 PP(pp_lcfirst)
3233 {
3234     dSP;
3235     SV *sv = TOPs;
3236     register U8 *s;
3237     STRLEN slen;
3238
3239     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3240         STRLEN ulen;
3241         U8 tmpbuf[UTF8_MAXLEN*2+1];
3242         U8 *tend;
3243         UV uv;
3244
3245         toLOWER_utf8(s, tmpbuf, &ulen);
3246         uv = utf8_to_uvchr(tmpbuf, 0);
3247
3248         tend = uvchr_to_utf8(tmpbuf, uv);
3249
3250         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3251             dTARGET;
3252             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3253             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3254             SvUTF8_on(TARG);
3255             SETs(TARG);
3256         }
3257         else {
3258             s = (U8*)SvPV_force(sv, slen);
3259             Copy(tmpbuf, s, ulen, U8);
3260         }
3261     }
3262     else {
3263         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3264             dTARGET;
3265             SvUTF8_off(TARG);                           /* decontaminate */
3266             sv_setsv(TARG, sv);
3267             sv = TARG;
3268             SETs(sv);
3269         }
3270         s = (U8*)SvPV_force(sv, slen);
3271         if (*s) {
3272             if (IN_LOCALE_RUNTIME) {
3273                 TAINT;
3274                 SvTAINTED_on(sv);
3275                 *s = toLOWER_LC(*s);
3276             }
3277             else
3278                 *s = toLOWER(*s);
3279         }
3280     }
3281     if (SvSMAGICAL(sv))
3282         mg_set(sv);
3283     RETURN;
3284 }
3285
3286 PP(pp_uc)
3287 {
3288     dSP;
3289     SV *sv = TOPs;
3290     register U8 *s;
3291     STRLEN len;
3292
3293     if (DO_UTF8(sv)) {
3294         dTARGET;
3295         STRLEN ulen;
3296         register U8 *d;
3297         U8 *send;
3298         U8 tmpbuf[UTF8_MAXLEN*2+1];
3299
3300         s = (U8*)SvPV(sv,len);
3301         if (!len) {
3302             SvUTF8_off(TARG);                           /* decontaminate */
3303             sv_setpvn(TARG, "", 0);
3304             SETs(TARG);
3305         }
3306         else {
3307             (void)SvUPGRADE(TARG, SVt_PV);
3308             SvGROW(TARG, (len * 2) + 1);
3309             (void)SvPOK_only(TARG);
3310             d = (U8*)SvPVX(TARG);
3311             send = s + len;
3312             while (s < send) {
3313                 toUPPER_utf8(s, tmpbuf, &ulen);
3314                 Copy(tmpbuf, d, ulen, U8);
3315                 d += ulen;
3316                 s += UTF8SKIP(s);
3317             }
3318             *d = '\0';
3319             SvUTF8_on(TARG);
3320             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3321             SETs(TARG);
3322         }
3323     }
3324     else {
3325         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3326             dTARGET;
3327             SvUTF8_off(TARG);                           /* decontaminate */
3328             sv_setsv(TARG, sv);
3329             sv = TARG;
3330             SETs(sv);
3331         }
3332         s = (U8*)SvPV_force(sv, len);
3333         if (len) {
3334             register U8 *send = s + len;
3335
3336             if (IN_LOCALE_RUNTIME) {
3337                 TAINT;
3338                 SvTAINTED_on(sv);
3339                 for (; s < send; s++)
3340                     *s = toUPPER_LC(*s);
3341             }
3342             else {
3343                 for (; s < send; s++)
3344                     *s = toUPPER(*s);
3345             }
3346         }
3347     }
3348     if (SvSMAGICAL(sv))
3349         mg_set(sv);
3350     RETURN;
3351 }
3352
3353 PP(pp_lc)
3354 {
3355     dSP;
3356     SV *sv = TOPs;
3357     register U8 *s;
3358     STRLEN len;
3359
3360     if (DO_UTF8(sv)) {
3361         dTARGET;
3362         STRLEN ulen;
3363         register U8 *d;
3364         U8 *send;
3365         U8 tmpbuf[UTF8_MAXLEN*2+1];
3366
3367         s = (U8*)SvPV(sv,len);
3368         if (!len) {
3369             SvUTF8_off(TARG);                           /* decontaminate */
3370             sv_setpvn(TARG, "", 0);
3371             SETs(TARG);
3372         }
3373         else {
3374             (void)SvUPGRADE(TARG, SVt_PV);
3375             SvGROW(TARG, (len * 2) + 1);
3376             (void)SvPOK_only(TARG);
3377             d = (U8*)SvPVX(TARG);
3378             send = s + len;
3379             while (s < send) {
3380                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3381 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3382                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3383                      /*
3384                       * Now if the sigma is NOT followed by
3385                       * /$ignorable_sequence$cased_letter/;
3386                       * and it IS preceded by
3387                       * /$cased_letter$ignorable_sequence/;
3388                       * where $ignorable_sequence is
3389                       * [\x{2010}\x{AD}\p{Mn}]*
3390                       * and $cased_letter is
3391                       * [\p{Ll}\p{Lo}\p{Lt}]
3392                       * then it should be mapped to 0x03C2,
3393                       * (GREEK SMALL LETTER FINAL SIGMA),
3394                       * instead of staying 0x03A3.
3395                       * See lib/unicore/SpecCase.txt.
3396                       */
3397                 }
3398                 Copy(tmpbuf, d, ulen, U8);
3399                 d += ulen;
3400                 s += UTF8SKIP(s);
3401             }
3402             *d = '\0';
3403             SvUTF8_on(TARG);
3404             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3405             SETs(TARG);
3406         }
3407     }
3408     else {
3409         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3410             dTARGET;
3411             SvUTF8_off(TARG);                           /* decontaminate */
3412             sv_setsv(TARG, sv);
3413             sv = TARG;
3414             SETs(sv);
3415         }
3416
3417         s = (U8*)SvPV_force(sv, len);
3418         if (len) {
3419             register U8 *send = s + len;
3420
3421             if (IN_LOCALE_RUNTIME) {
3422                 TAINT;
3423                 SvTAINTED_on(sv);
3424                 for (; s < send; s++)
3425                     *s = toLOWER_LC(*s);
3426             }
3427             else {
3428                 for (; s < send; s++)
3429                     *s = toLOWER(*s);
3430             }
3431         }
3432     }
3433     if (SvSMAGICAL(sv))
3434         mg_set(sv);
3435     RETURN;
3436 }
3437
3438 PP(pp_quotemeta)
3439 {
3440     dSP; dTARGET;
3441     SV *sv = TOPs;
3442     STRLEN len;
3443     register char *s = SvPV(sv,len);
3444     register char *d;
3445
3446     SvUTF8_off(TARG);                           /* decontaminate */
3447     if (len) {
3448         (void)SvUPGRADE(TARG, SVt_PV);
3449         SvGROW(TARG, (len * 2) + 1);
3450         d = SvPVX(TARG);
3451         if (DO_UTF8(sv)) {
3452             while (len) {
3453                 if (UTF8_IS_CONTINUED(*s)) {
3454                     STRLEN ulen = UTF8SKIP(s);
3455                     if (ulen > len)
3456                         ulen = len;
3457                     len -= ulen;
3458                     while (ulen--)
3459                         *d++ = *s++;
3460                 }
3461                 else {
3462                     if (!isALNUM(*s))
3463                         *d++ = '\\';
3464                     *d++ = *s++;
3465                     len--;
3466                 }
3467             }
3468             SvUTF8_on(TARG);
3469         }
3470         else {
3471             while (len--) {
3472                 if (!isALNUM(*s))
3473                     *d++ = '\\';
3474                 *d++ = *s++;
3475             }
3476         }
3477         *d = '\0';
3478         SvCUR_set(TARG, d - SvPVX(TARG));
3479         (void)SvPOK_only_UTF8(TARG);
3480     }
3481     else
3482         sv_setpvn(TARG, s, len);
3483     SETs(TARG);
3484     if (SvSMAGICAL(TARG))
3485         mg_set(TARG);
3486     RETURN;
3487 }
3488
3489 /* Arrays. */
3490
3491 PP(pp_aslice)
3492 {
3493     dSP; dMARK; dORIGMARK;
3494     register SV** svp;
3495     register AV* av = (AV*)POPs;
3496     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3497     I32 arybase = PL_curcop->cop_arybase;
3498     I32 elem;
3499
3500     if (SvTYPE(av) == SVt_PVAV) {
3501         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3502             I32 max = -1;
3503             for (svp = MARK + 1; svp <= SP; svp++) {
3504                 elem = SvIVx(*svp);
3505                 if (elem > max)
3506                     max = elem;
3507             }
3508             if (max > AvMAX(av))
3509                 av_extend(av, max);
3510         }
3511         while (++MARK <= SP) {
3512             elem = SvIVx(*MARK);
3513
3514             if (elem > 0)
3515                 elem -= arybase;
3516             svp = av_fetch(av, elem, lval);
3517             if (lval) {
3518                 if (!svp || *svp == &PL_sv_undef)
3519                     DIE(aTHX_ PL_no_aelem, elem);
3520                 if (PL_op->op_private & OPpLVAL_INTRO)
3521                     save_aelem(av, elem, svp);
3522             }
3523             *MARK = svp ? *svp : &PL_sv_undef;
3524         }
3525     }
3526     if (GIMME != G_ARRAY) {
3527         MARK = ORIGMARK;
3528         *++MARK = *SP;
3529         SP = MARK;
3530     }
3531     RETURN;
3532 }
3533
3534 /* Associative arrays. */
3535
3536 PP(pp_each)
3537 {
3538     dSP;
3539     HV *hash = (HV*)POPs;
3540     HE *entry;
3541     I32 gimme = GIMME_V;
3542     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3543
3544     PUTBACK;
3545     /* might clobber stack_sp */
3546     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3547     SPAGAIN;
3548
3549     EXTEND(SP, 2);
3550     if (entry) {
3551         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
3552         if (gimme == G_ARRAY) {
3553             SV *val;
3554             PUTBACK;
3555             /* might clobber stack_sp */
3556             val = realhv ?
3557                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3558             SPAGAIN;
3559             PUSHs(val);
3560         }
3561     }
3562     else if (gimme == G_SCALAR)
3563         RETPUSHUNDEF;
3564
3565     RETURN;
3566 }
3567
3568 PP(pp_values)
3569 {
3570     return do_kv();
3571 }
3572
3573 PP(pp_keys)
3574 {
3575     return do_kv();
3576 }
3577
3578 PP(pp_delete)
3579 {
3580     dSP;
3581     I32 gimme = GIMME_V;
3582     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3583     SV *sv;
3584     HV *hv;
3585
3586     if (PL_op->op_private & OPpSLICE) {
3587         dMARK; dORIGMARK;
3588         U32 hvtype;
3589         hv = (HV*)POPs;
3590         hvtype = SvTYPE(hv);
3591         if (hvtype == SVt_PVHV) {                       /* hash element */
3592             while (++MARK <= SP) {
3593                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3594                 *MARK = sv ? sv : &PL_sv_undef;
3595             }
3596         }
3597         else if (hvtype == SVt_PVAV) {
3598             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
3599                 while (++MARK <= SP) {
3600                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3601                     *MARK = sv ? sv : &PL_sv_undef;
3602                 }
3603             }
3604             else {                                      /* pseudo-hash element */
3605                 while (++MARK <= SP) {
3606                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3607                     *MARK = sv ? sv : &PL_sv_undef;
3608                 }
3609             }
3610         }
3611         else
3612             DIE(aTHX_ "Not a HASH reference");
3613         if (discard)
3614             SP = ORIGMARK;
3615         else if (gimme == G_SCALAR) {
3616             MARK = ORIGMARK;
3617             *++MARK = *SP;
3618             SP = MARK;
3619         }
3620     }
3621     else {
3622         SV *keysv = POPs;
3623         hv = (HV*)POPs;
3624         if (SvTYPE(hv) == SVt_PVHV)
3625             sv = hv_delete_ent(hv, keysv, discard, 0);
3626         else if (SvTYPE(hv) == SVt_PVAV) {
3627             if (PL_op->op_flags & OPf_SPECIAL)
3628                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3629             else
3630                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3631         }
3632         else
3633             DIE(aTHX_ "Not a HASH reference");
3634         if (!sv)
3635             sv = &PL_sv_undef;
3636         if (!discard)
3637             PUSHs(sv);
3638     }
3639     RETURN;
3640 }
3641
3642 PP(pp_exists)
3643 {
3644     dSP;
3645     SV *tmpsv;
3646     HV *hv;
3647
3648     if (PL_op->op_private & OPpEXISTS_SUB) {
3649         GV *gv;
3650         CV *cv;
3651         SV *sv = POPs;
3652         cv = sv_2cv(sv, &hv, &gv, FALSE);
3653         if (cv)
3654             RETPUSHYES;
3655         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3656             RETPUSHYES;
3657         RETPUSHNO;
3658     }
3659     tmpsv = POPs;
3660     hv = (HV*)POPs;
3661     if (SvTYPE(hv) == SVt_PVHV) {
3662         if (hv_exists_ent(hv, tmpsv, 0))
3663             RETPUSHYES;
3664     }
3665     else if (SvTYPE(hv) == SVt_PVAV) {
3666         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3667             if (av_exists((AV*)hv, SvIV(tmpsv)))
3668                 RETPUSHYES;
3669         }
3670         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
3671             RETPUSHYES;
3672     }
3673     else {
3674         DIE(aTHX_ "Not a HASH reference");
3675     }
3676     RETPUSHNO;
3677 }
3678
3679 PP(pp_hslice)
3680 {
3681     dSP; dMARK; dORIGMARK;
3682     register HV *hv = (HV*)POPs;
3683     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3684     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3685
3686     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3687         DIE(aTHX_ "Can't localize pseudo-hash element");
3688
3689     if (realhv || SvTYPE(hv) == SVt_PVAV) {
3690         while (++MARK <= SP) {
3691             SV *keysv = *MARK;
3692             SV **svp;
3693             I32 preeminent = SvRMAGICAL(hv) ? 1 :
3694                                 realhv ? hv_exists_ent(hv, keysv, 0)
3695                                        : avhv_exists_ent((AV*)hv, keysv, 0);
3696             if (realhv) {
3697                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3698                 svp = he ? &HeVAL(he) : 0;
3699             }
3700             else {
3701                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3702             }
3703             if (lval) {
3704                 if (!svp || *svp == &PL_sv_undef) {
3705                     STRLEN n_a;
3706                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3707                 }
3708                 if (PL_op->op_private & OPpLVAL_INTRO) {
3709                     if (preeminent)
3710                         save_helem(hv, keysv, svp);
3711                     else {
3712                         STRLEN keylen;
3713                         char *key = SvPV(keysv, keylen);
3714                         SAVEDELETE(hv, savepvn(key,keylen), keylen);
3715                     }
3716                 }
3717             }
3718             *MARK = svp ? *svp : &PL_sv_undef;
3719         }
3720     }
3721     if (GIMME != G_ARRAY) {
3722         MARK = ORIGMARK;
3723         *++MARK = *SP;
3724         SP = MARK;
3725     }
3726     RETURN;
3727 }
3728
3729 /* List operators. */
3730
3731 PP(pp_list)
3732 {
3733     dSP; dMARK;
3734     if (GIMME != G_ARRAY) {
3735         if (++MARK <= SP)
3736             *MARK = *SP;                /* unwanted list, return last item */
3737         else
3738             *MARK = &PL_sv_undef;
3739         SP = MARK;
3740     }
3741     RETURN;
3742 }
3743
3744 PP(pp_lslice)
3745 {
3746     dSP;
3747     SV **lastrelem = PL_stack_sp;
3748     SV **lastlelem = PL_stack_base + POPMARK;
3749     SV **firstlelem = PL_stack_base + POPMARK + 1;
3750     register SV **firstrelem = lastlelem + 1;
3751     I32 arybase = PL_curcop->cop_arybase;
3752     I32 lval = PL_op->op_flags & OPf_MOD;
3753     I32 is_something_there = lval;
3754
3755     register I32 max = lastrelem - lastlelem;
3756     register SV **lelem;
3757     register I32 ix;
3758
3759     if (GIMME != G_ARRAY) {
3760         ix = SvIVx(*lastlelem);
3761         if (ix < 0)
3762             ix += max;
3763         else
3764             ix -= arybase;
3765         if (ix < 0 || ix >= max)
3766             *firstlelem = &PL_sv_undef;
3767         else
3768             *firstlelem = firstrelem[ix];
3769         SP = firstlelem;
3770         RETURN;
3771     }
3772
3773     if (max == 0) {
3774         SP = firstlelem - 1;
3775         RETURN;
3776     }
3777
3778     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3779         ix = SvIVx(*lelem);
3780         if (ix < 0)
3781             ix += max;
3782         else
3783             ix -= arybase;
3784         if (ix < 0 || ix >= max)
3785             *lelem = &PL_sv_undef;
3786         else {
3787             is_something_there = TRUE;
3788             if (!(*lelem = firstrelem[ix]))
3789                 *lelem = &PL_sv_undef;
3790         }
3791     }
3792     if (is_something_there)
3793         SP = lastlelem;
3794     else
3795         SP = firstlelem - 1;
3796     RETURN;
3797 }
3798
3799 PP(pp_anonlist)
3800 {
3801     dSP; dMARK; dORIGMARK;
3802     I32 items = SP - MARK;
3803     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3804     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3805     XPUSHs(av);
3806     RETURN;
3807 }
3808
3809 PP(pp_anonhash)
3810 {
3811     dSP; dMARK; dORIGMARK;
3812     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3813
3814     while (MARK < SP) {
3815         SV* key = *++MARK;
3816         SV *val = NEWSV(46, 0);
3817         if (MARK < SP)
3818             sv_setsv(val, *++MARK);
3819         else if (ckWARN(WARN_MISC))
3820             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3821         (void)hv_store_ent(hv,key,val,0);
3822     }
3823     SP = ORIGMARK;
3824     XPUSHs((SV*)hv);
3825     RETURN;
3826 }
3827
3828 PP(pp_splice)
3829 {
3830     dSP; dMARK; dORIGMARK;
3831     register AV *ary = (AV*)*++MARK;
3832     register SV **src;
3833     register SV **dst;
3834     register I32 i;
3835     register I32 offset;
3836     register I32 length;
3837     I32 newlen;
3838     I32 after;
3839     I32 diff;
3840     SV **tmparyval = 0;
3841     MAGIC *mg;
3842
3843     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3844         *MARK-- = SvTIED_obj((SV*)ary, mg);
3845         PUSHMARK(MARK);
3846         PUTBACK;
3847         ENTER;
3848         call_method("SPLICE",GIMME_V);
3849         LEAVE;
3850         SPAGAIN;
3851         RETURN;
3852     }
3853
3854     SP++;
3855
3856     if (++MARK < SP) {
3857         offset = i = SvIVx(*MARK);
3858         if (offset < 0)
3859             offset += AvFILLp(ary) + 1;
3860         else
3861             offset -= PL_curcop->cop_arybase;
3862         if (offset < 0)
3863             DIE(aTHX_ PL_no_aelem, i);
3864         if (++MARK < SP) {
3865             length = SvIVx(*MARK++);
3866             if (length < 0) {
3867                 length += AvFILLp(ary) - offset + 1;
3868                 if (length < 0)
3869                     length = 0;
3870             }
3871         }
3872         else
3873             length = AvMAX(ary) + 1;            /* close enough to infinity */
3874     }
3875     else {
3876         offset = 0;
3877         length = AvMAX(ary) + 1;
3878     }
3879     if (offset > AvFILLp(ary) + 1)
3880         offset = AvFILLp(ary) + 1;
3881     after = AvFILLp(ary) + 1 - (offset + length);
3882     if (after < 0) {                            /* not that much array */
3883         length += after;                        /* offset+length now in array */
3884         after = 0;
3885         if (!AvALLOC(ary))
3886             av_extend(ary, 0);
3887     }
3888
3889     /* At this point, MARK .. SP-1 is our new LIST */
3890
3891     newlen = SP - MARK;
3892     diff = newlen - length;
3893     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3894         av_reify(ary);
3895
3896     if (diff < 0) {                             /* shrinking the area */
3897         if (newlen) {
3898             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3899             Copy(MARK, tmparyval, newlen, SV*);
3900         }
3901
3902         MARK = ORIGMARK + 1;
3903         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3904             MEXTEND(MARK, length);
3905             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3906             if (AvREAL(ary)) {
3907                 EXTEND_MORTAL(length);
3908                 for (i = length, dst = MARK; i; i--) {
3909                     sv_2mortal(*dst);   /* free them eventualy */
3910                     dst++;
3911                 }
3912             }
3913             MARK += length - 1;
3914         }
3915         else {
3916             *MARK = AvARRAY(ary)[offset+length-1];
3917             if (AvREAL(ary)) {
3918                 sv_2mortal(*MARK);
3919                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3920                     SvREFCNT_dec(*dst++);       /* free them now */
3921             }
3922         }
3923         AvFILLp(ary) += diff;
3924
3925         /* pull up or down? */
3926
3927         if (offset < after) {                   /* easier to pull up */
3928             if (offset) {                       /* esp. if nothing to pull */
3929                 src = &AvARRAY(ary)[offset-1];
3930                 dst = src - diff;               /* diff is negative */
3931                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3932                     *dst-- = *src--;
3933             }
3934             dst = AvARRAY(ary);
3935             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3936             AvMAX(ary) += diff;
3937         }
3938         else {
3939             if (after) {                        /* anything to pull down? */
3940                 src = AvARRAY(ary) + offset + length;
3941                 dst = src + diff;               /* diff is negative */
3942                 Move(src, dst, after, SV*);
3943             }
3944             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3945                                                 /* avoid later double free */
3946         }
3947         i = -diff;
3948         while (i)
3949             dst[--i] = &PL_sv_undef;
3950
3951         if (newlen) {
3952             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3953               newlen; newlen--) {
3954                 *dst = NEWSV(46, 0);
3955                 sv_setsv(*dst++, *src++);
3956             }
3957             Safefree(tmparyval);
3958         }
3959     }
3960     else {                                      /* no, expanding (or same) */
3961         if (length) {
3962             New(452, tmparyval, length, SV*);   /* so remember deletion */
3963             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3964         }
3965
3966         if (diff > 0) {                         /* expanding */
3967
3968             /* push up or down? */
3969
3970             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3971                 if (offset) {
3972                     src = AvARRAY(ary);
3973                     dst = src - diff;
3974                     Move(src, dst, offset, SV*);
3975                 }
3976                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3977                 AvMAX(ary) += diff;
3978                 AvFILLp(ary) += diff;
3979             }
3980             else {
3981                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3982                     av_extend(ary, AvFILLp(ary) + diff);
3983                 AvFILLp(ary) += diff;
3984
3985                 if (after) {
3986                     dst = AvARRAY(ary) + AvFILLp(ary);
3987                     src = dst - diff;
3988                     for (i = after; i; i--) {
3989                         *dst-- = *src--;
3990                     }
3991                 }
3992             }
3993         }
3994
3995         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3996             *dst = NEWSV(46, 0);
3997             sv_setsv(*dst++, *src++);
3998         }
3999         MARK = ORIGMARK + 1;
4000         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4001             if (length) {
4002                 Copy(tmparyval, MARK, length, SV*);
4003                 if (AvREAL(ary)) {
4004                     EXTEND_MORTAL(length);
4005                     for (i = length, dst = MARK; i; i--) {
4006                         sv_2mortal(*dst);       /* free them eventualy */
4007                         dst++;
4008                     }
4009                 }
4010                 Safefree(tmparyval);
4011             }
4012             MARK += length - 1;
4013         }
4014         else if (length--) {
4015             *MARK = tmparyval[length];
4016             if (AvREAL(ary)) {
4017                 sv_2mortal(*MARK);
4018                 while (length-- > 0)
4019                     SvREFCNT_dec(tmparyval[length]);
4020             }
4021             Safefree(tmparyval);
4022         }
4023         else
4024             *MARK = &PL_sv_undef;
4025     }
4026     SP = MARK;
4027     RETURN;
4028 }
4029
4030 PP(pp_push)
4031 {
4032     dSP; dMARK; dORIGMARK; dTARGET;
4033     register AV *ary = (AV*)*++MARK;
4034     register SV *sv = &PL_sv_undef;
4035     MAGIC *mg;
4036
4037     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4038         *MARK-- = SvTIED_obj((SV*)ary, mg);
4039         PUSHMARK(MARK);
4040         PUTBACK;
4041         ENTER;
4042         call_method("PUSH",G_SCALAR|G_DISCARD);
4043         LEAVE;
4044         SPAGAIN;
4045     }
4046     else {
4047         /* Why no pre-extend of ary here ? */
4048         for (++MARK; MARK <= SP; MARK++) {
4049             sv = NEWSV(51, 0);
4050             if (*MARK)
4051                 sv_setsv(sv, *MARK);
4052             av_push(ary, sv);
4053         }
4054     }
4055     SP = ORIGMARK;
4056     PUSHi( AvFILL(ary) + 1 );
4057     RETURN;
4058 }
4059
4060 PP(pp_pop)
4061 {
4062     dSP;
4063     AV *av = (AV*)POPs;
4064     SV *sv = av_pop(av);
4065     if (AvREAL(av))
4066         (void)sv_2mortal(sv);
4067     PUSHs(sv);
4068     RETURN;
4069 }
4070
4071 PP(pp_shift)
4072 {
4073     dSP;
4074     AV *av = (AV*)POPs;
4075     SV *sv = av_shift(av);
4076     EXTEND(SP, 1);
4077     if (!sv)
4078         RETPUSHUNDEF;
4079     if (AvREAL(av))
4080         (void)sv_2mortal(sv);
4081     PUSHs(sv);
4082     RETURN;
4083 }
4084
4085 PP(pp_unshift)
4086 {
4087     dSP; dMARK; dORIGMARK; dTARGET;
4088     register AV *ary = (AV*)*++MARK;
4089     register SV *sv;
4090     register I32 i = 0;
4091     MAGIC *mg;
4092
4093     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4094         *MARK-- = SvTIED_obj((SV*)ary, mg);
4095         PUSHMARK(MARK);
4096         PUTBACK;
4097         ENTER;
4098         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4099         LEAVE;
4100         SPAGAIN;
4101     }
4102     else {
4103         av_unshift(ary, SP - MARK);
4104         while (MARK < SP) {
4105             sv = NEWSV(27, 0);
4106             sv_setsv(sv, *++MARK);
4107             (void)av_store(ary, i++, sv);
4108         }
4109     }
4110     SP = ORIGMARK;
4111     PUSHi( AvFILL(ary) + 1 );
4112     RETURN;
4113 }
4114
4115 PP(pp_reverse)
4116 {
4117     dSP; dMARK;
4118     register SV *tmp;
4119     SV **oldsp = SP;
4120
4121     if (GIMME == G_ARRAY) {
4122         MARK++;
4123         while (MARK < SP) {
4124             tmp = *MARK;
4125             *MARK++ = *SP;
4126             *SP-- = tmp;
4127         }
4128         /* safe as long as stack cannot get extended in the above */
4129         SP = oldsp;
4130     }
4131     else {
4132         register char *up;
4133         register char *down;
4134         register I32 tmp;
4135         dTARGET;
4136         STRLEN len;
4137
4138         SvUTF8_off(TARG);                               /* decontaminate */
4139         if (SP - MARK > 1)
4140             do_join(TARG, &PL_sv_no, MARK, SP);
4141         else
4142             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4143         up = SvPV_force(TARG, len);
4144         if (len > 1) {
4145             if (DO_UTF8(TARG)) {        /* first reverse each character */
4146                 U8* s = (U8*)SvPVX(TARG);
4147                 U8* send = (U8*)(s + len);
4148                 while (s < send) {
4149                     if (UTF8_IS_INVARIANT(*s)) {
4150                         s++;
4151                         continue;
4152                     }
4153                     else {
4154                         if (!utf8_to_uvchr(s, 0))
4155                             break;
4156                         up = (char*)s;
4157                         s += UTF8SKIP(s);
4158                         down = (char*)(s - 1);
4159                         /* reverse this character */
4160                         while (down > up) {
4161                             tmp = *up;
4162                             *up++ = *down;
4163                             *down-- = tmp;
4164                         }
4165                     }
4166                 }
4167                 up = SvPVX(TARG);
4168             }
4169             down = SvPVX(TARG) + len - 1;
4170             while (down > up) {
4171                 tmp = *up;
4172                 *up++ = *down;
4173                 *down-- = tmp;
4174             }
4175             (void)SvPOK_only_UTF8(TARG);
4176         }
4177         SP = MARK + 1;
4178         SETTARG;
4179     }
4180     RETURN;
4181 }
4182
4183 PP(pp_split)
4184 {
4185     dSP; dTARG;
4186     AV *ary;
4187     register IV limit = POPi;                   /* note, negative is forever */
4188     SV *sv = POPs;
4189     STRLEN len;
4190     register char *s = SvPV(sv, len);
4191     bool do_utf8 = DO_UTF8(sv);
4192     char *strend = s + len;
4193     register PMOP *pm;
4194     register REGEXP *rx;
4195     register SV *dstr;
4196     register char *m;
4197     I32 iters = 0;
4198     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4199     I32 maxiters = slen + 10;
4200     I32 i;
4201     char *orig;
4202     I32 origlimit = limit;
4203     I32 realarray = 0;
4204     I32 base;
4205     AV *oldstack = PL_curstack;
4206     I32 gimme = GIMME_V;
4207     I32 oldsave = PL_savestack_ix;
4208     I32 make_mortal = 1;
4209     MAGIC *mg = (MAGIC *) NULL;
4210
4211 #ifdef DEBUGGING
4212     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4213 #else
4214     pm = (PMOP*)POPs;
4215 #endif
4216     if (!pm || !s)
4217         DIE(aTHX_ "panic: pp_split");
4218     rx = PM_GETRE(pm);
4219
4220     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4221              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4222
4223     PL_reg_match_utf8 = do_utf8;
4224
4225     if (pm->op_pmreplroot) {
4226 #ifdef USE_ITHREADS
4227         ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4228 #else
4229         ary = GvAVn((GV*)pm->op_pmreplroot);
4230 #endif
4231     }
4232     else if (gimme != G_ARRAY)
4233 #ifdef USE_5005THREADS
4234         ary = (AV*)PL_curpad[0];
4235 #else
4236         ary = GvAVn(PL_defgv);
4237 #endif /* USE_5005THREADS */
4238     else
4239         ary = Nullav;
4240     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4241         realarray = 1;
4242         PUTBACK;
4243         av_extend(ary,0);
4244         av_clear(ary);
4245         SPAGAIN;
4246         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4247             PUSHMARK(SP);
4248             XPUSHs(SvTIED_obj((SV*)ary, mg));
4249         }
4250         else {
4251             if (!AvREAL(ary)) {
4252                 AvREAL_on(ary);
4253                 AvREIFY_off(ary);
4254                 for (i = AvFILLp(ary); i >= 0; i--)
4255                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4256             }
4257             /* temporarily switch stacks */
4258             SWITCHSTACK(PL_curstack, ary);
4259             make_mortal = 0;
4260         }
4261     }
4262     base = SP - PL_stack_base;
4263     orig = s;
4264     if (pm->op_pmflags & PMf_SKIPWHITE) {
4265         if (pm->op_pmflags & PMf_LOCALE) {
4266             while (isSPACE_LC(*s))
4267                 s++;
4268         }
4269         else {
4270             while (isSPACE(*s))
4271                 s++;
4272         }
4273     }
4274     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4275         SAVEINT(PL_multiline);
4276         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4277     }
4278
4279     if (!limit)
4280         limit = maxiters + 2;
4281     if (pm->op_pmflags & PMf_WHITE) {
4282         while (--limit) {
4283             m = s;
4284             while (m < strend &&
4285                    !((pm->op_pmflags & PMf_LOCALE)
4286                      ? isSPACE_LC(*m) : isSPACE(*m)))
4287                 ++m;
4288             if (m >= strend)
4289                 break;
4290
4291             dstr = NEWSV(30, m-s);
4292             sv_setpvn(dstr, s, m-s);
4293             if (make_mortal)
4294                 sv_2mortal(dstr);
4295             if (do_utf8)
4296                 (void)SvUTF8_on(dstr);
4297             XPUSHs(dstr);
4298
4299             s = m + 1;
4300             while (s < strend &&
4301                    ((pm->op_pmflags & PMf_LOCALE)
4302                     ? isSPACE_LC(*s) : isSPACE(*s)))
4303                 ++s;
4304         }
4305     }
4306     else if (strEQ("^", rx->precomp)) {
4307         while (--limit) {
4308             /*SUPPRESS 530*/
4309             for (m = s; m < strend && *m != '\n'; m++) ;
4310             m++;
4311             if (m >= strend)
4312                 break;
4313             dstr = NEWSV(30, m-s);
4314             sv_setpvn(dstr, s, m-s);
4315             if (make_mortal)
4316                 sv_2mortal(dstr);
4317             if (do_utf8)
4318                 (void)SvUTF8_on(dstr);
4319             XPUSHs(dstr);
4320             s = m;
4321         }
4322     }
4323     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4324              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4325              && (rx->reganch & ROPT_CHECK_ALL)
4326              && !(rx->reganch & ROPT_ANCH)) {
4327         int tail = (rx->reganch & RE_INTUIT_TAIL);
4328         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4329
4330         len = rx->minlen;
4331         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4332             STRLEN n_a;
4333             char c = *SvPV(csv, n_a);
4334             while (--limit) {
4335                 /*SUPPRESS 530*/
4336                 for (m = s; m < strend && *m != c; m++) ;
4337                 if (m >= strend)
4338                     break;
4339                 dstr = NEWSV(30, m-s);
4340                 sv_setpvn(dstr, s, m-s);
4341                 if (make_mortal)
4342                     sv_2mortal(dstr);
4343                 if (do_utf8)
4344                     (void)SvUTF8_on(dstr);
4345                 XPUSHs(dstr);
4346                 /* The rx->minlen is in characters but we want to step
4347                  * s ahead by bytes. */
4348                 if (do_utf8)
4349                     s = (char*)utf8_hop((U8*)m, len);
4350                 else
4351                     s = m + len; /* Fake \n at the end */
4352             }
4353         }
4354         else {
4355 #ifndef lint
4356             while (s < strend && --limit &&
4357               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4358                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4359 #endif
4360             {
4361                 dstr = NEWSV(31, m-s);
4362                 sv_setpvn(dstr, s, m-s);
4363                 if (make_mortal)
4364                     sv_2mortal(dstr);
4365                 if (do_utf8)
4366                     (void)SvUTF8_on(dstr);
4367                 XPUSHs(dstr);
4368                 /* The rx->minlen is in characters but we want to step
4369                  * s ahead by bytes. */
4370                 if (do_utf8)
4371                     s = (char*)utf8_hop((U8*)m, len);
4372                 else
4373                     s = m + len; /* Fake \n at the end */
4374             }
4375         }
4376     }
4377     else {
4378         maxiters += slen * rx->nparens;
4379         while (s < strend && --limit
4380 /*             && (!rx->check_substr
4381                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4382                                                  0, NULL))))
4383 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4384                               1 /* minend */, sv, NULL, 0))
4385         {
4386             TAINT_IF(RX_MATCH_TAINTED(rx));
4387             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4388                 m = s;
4389                 s = orig;
4390                 orig = rx->subbeg;
4391                 s = orig + (m - s);
4392                 strend = s + (strend - m);
4393             }
4394             m = rx->startp[0] + orig;
4395             dstr = NEWSV(32, m-s);
4396             sv_setpvn(dstr, s, m-s);
4397             if (make_mortal)
4398                 sv_2mortal(dstr);
4399             if (do_utf8)
4400                 (void)SvUTF8_on(dstr);
4401             XPUSHs(dstr);
4402             if (rx->nparens) {
4403                 for (i = 1; i <= rx->nparens; i++) {
4404                     s = rx->startp[i] + orig;
4405                     m = rx->endp[i] + orig;
4406
4407                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4408                        parens that didn't match -- they should be set to
4409                        undef, not the empty string */
4410                     if (m >= orig && s >= orig) {
4411                         dstr = NEWSV(33, m-s);
4412                         sv_setpvn(dstr, s, m-s);
4413                     }
4414                     else
4415                         dstr = &PL_sv_undef;  /* undef, not "" */
4416                     if (make_mortal)
4417                         sv_2mortal(dstr);
4418                     if (do_utf8)
4419                         (void)SvUTF8_on(dstr);
4420                     XPUSHs(dstr);
4421                 }
4422             }
4423             s = rx->endp[0] + orig;
4424         }
4425     }
4426
4427     LEAVE_SCOPE(oldsave);
4428     iters = (SP - PL_stack_base) - base;
4429     if (iters > maxiters)
4430         DIE(aTHX_ "Split loop");
4431
4432     /* keep field after final delim? */
4433     if (s < strend || (iters && origlimit)) {
4434         STRLEN l = strend - s;
4435         dstr = NEWSV(34, l);
4436         sv_setpvn(dstr, s, l);
4437         if (make_mortal)
4438             sv_2mortal(dstr);
4439         if (do_utf8)
4440             (void)SvUTF8_on(dstr);
4441         XPUSHs(dstr);
4442         iters++;
4443     }
4444     else if (!origlimit) {
4445         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4446             iters--, SP--;
4447     }
4448
4449     if (realarray) {
4450         if (!mg) {
4451             SWITCHSTACK(ary, oldstack);
4452             if (SvSMAGICAL(ary)) {
4453                 PUTBACK;
4454                 mg_set((SV*)ary);
4455                 SPAGAIN;
4456             }
4457             if (gimme == G_ARRAY) {
4458                 EXTEND(SP, iters);
4459                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4460                 SP += iters;
4461                 RETURN;
4462             }
4463         }
4464         else {
4465             PUTBACK;
4466             ENTER;
4467             call_method("PUSH",G_SCALAR|G_DISCARD);
4468             LEAVE;
4469             SPAGAIN;
4470             if (gimme == G_ARRAY) {
4471                 /* EXTEND should not be needed - we just popped them */
4472                 EXTEND(SP, iters);
4473                 for (i=0; i < iters; i++) {
4474                     SV **svp = av_fetch(ary, i, FALSE);
4475                     PUSHs((svp) ? *svp : &PL_sv_undef);
4476                 }
4477                 RETURN;
4478             }
4479         }
4480     }
4481     else {
4482         if (gimme == G_ARRAY)
4483             RETURN;
4484     }
4485     if (iters || !pm->op_pmreplroot) {
4486         GETTARGET;
4487         PUSHi(iters);
4488         RETURN;
4489     }
4490     RETPUSHUNDEF;
4491 }
4492
4493 #ifdef USE_5005THREADS
4494 void
4495 Perl_unlock_condpair(pTHX_ void *svv)
4496 {
4497     MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4498
4499     if (!mg)
4500         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4501     MUTEX_LOCK(MgMUTEXP(mg));
4502     if (MgOWNER(mg) != thr)
4503         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4504     MgOWNER(mg) = 0;
4505     COND_SIGNAL(MgOWNERCONDP(mg));
4506     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4507                           PTR2UV(thr), PTR2UV(svv)));
4508     MUTEX_UNLOCK(MgMUTEXP(mg));
4509 }
4510 #endif /* USE_5005THREADS */
4511
4512 PP(pp_lock)
4513 {
4514     dSP;
4515     dTOPss;
4516     SV *retsv = sv;
4517 #ifdef USE_5005THREADS
4518     sv_lock(sv);
4519 #endif /* USE_5005THREADS */
4520 #ifdef USE_ITHREADS
4521     shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4522     if(ssv)
4523         Perl_sharedsv_lock(aTHX_ ssv);
4524 #endif /* USE_ITHREADS */
4525     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4526         || SvTYPE(retsv) == SVt_PVCV) {
4527         retsv = refto(retsv);
4528     }
4529     SETs(retsv);
4530     RETURN;
4531 }
4532
4533 PP(pp_threadsv)
4534 {
4535 #ifdef USE_5005THREADS
4536     dSP;
4537     EXTEND(SP, 1);
4538     if (PL_op->op_private & OPpLVAL_INTRO)
4539         PUSHs(*save_threadsv(PL_op->op_targ));
4540     else
4541         PUSHs(THREADSV(PL_op->op_targ));
4542     RETURN;
4543 #else
4544     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4545 #endif /* USE_5005THREADS */
4546 }