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