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) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3153         STRLEN ulen;
3154         U8 tmpbuf[UTF8_MAXLEN+1];
3155         U8 *tend;
3156         UV uv;
3157
3158         if (IN_LOCALE_RUNTIME) {
3159             TAINT;
3160             SvTAINTED_on(sv);
3161             uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3162         }
3163         else {
3164             uv   = toTITLE_utf8(s);
3165             ulen = UNISKIP(uv);
3166         }
3167
3168         tend = uvchr_to_utf8(tmpbuf, uv);
3169
3170         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3171             dTARGET;
3172             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3173             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3174             SvUTF8_on(TARG);
3175             SETs(TARG);
3176         }
3177         else {
3178             s = (U8*)SvPV_force(sv, slen);
3179             Copy(tmpbuf, s, ulen, U8);
3180         }
3181     }
3182     else {
3183         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3184             dTARGET;
3185             SvUTF8_off(TARG);                           /* decontaminate */
3186             sv_setsv(TARG, sv);
3187             sv = TARG;
3188             SETs(sv);
3189         }
3190         s = (U8*)SvPV_force(sv, slen);
3191         if (*s) {
3192             if (IN_LOCALE_RUNTIME) {
3193                 TAINT;
3194                 SvTAINTED_on(sv);
3195                 *s = toUPPER_LC(*s);
3196             }
3197             else
3198                 *s = toUPPER(*s);
3199         }
3200     }
3201     if (SvSMAGICAL(sv))
3202         mg_set(sv);
3203     RETURN;
3204 }
3205
3206 PP(pp_lcfirst)
3207 {
3208     dSP;
3209     SV *sv = TOPs;
3210     register U8 *s;
3211     STRLEN slen;
3212
3213     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3214         STRLEN ulen;
3215         U8 tmpbuf[UTF8_MAXLEN+1];
3216         U8 *tend;
3217         UV uv;
3218
3219         if (IN_LOCALE_RUNTIME) {
3220             TAINT;
3221             SvTAINTED_on(sv);
3222             uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3223         }
3224         else {
3225             uv   = toLOWER_utf8(s);
3226             ulen = UNISKIP(uv);
3227         }
3228
3229         tend = uvchr_to_utf8(tmpbuf, uv);
3230
3231         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3232             dTARGET;
3233             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3234             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3235             SvUTF8_on(TARG);
3236             SETs(TARG);
3237         }
3238         else {
3239             s = (U8*)SvPV_force(sv, slen);
3240             Copy(tmpbuf, s, ulen, U8);
3241         }
3242     }
3243     else {
3244         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3245             dTARGET;
3246             SvUTF8_off(TARG);                           /* decontaminate */
3247             sv_setsv(TARG, sv);
3248             sv = TARG;
3249             SETs(sv);
3250         }
3251         s = (U8*)SvPV_force(sv, slen);
3252         if (*s) {
3253             if (IN_LOCALE_RUNTIME) {
3254                 TAINT;
3255                 SvTAINTED_on(sv);
3256                 *s = toLOWER_LC(*s);
3257             }
3258             else
3259                 *s = toLOWER(*s);
3260         }
3261     }
3262     if (SvSMAGICAL(sv))
3263         mg_set(sv);
3264     RETURN;
3265 }
3266
3267 PP(pp_uc)
3268 {
3269     dSP;
3270     SV *sv = TOPs;
3271     register U8 *s;
3272     STRLEN len;
3273
3274     if (DO_UTF8(sv)) {
3275         dTARGET;
3276         STRLEN ulen;
3277         register U8 *d;
3278         U8 *send;
3279
3280         s = (U8*)SvPV(sv,len);
3281         if (!len) {
3282             SvUTF8_off(TARG);                           /* decontaminate */
3283             sv_setpvn(TARG, "", 0);
3284             SETs(TARG);
3285         }
3286         else {
3287             (void)SvUPGRADE(TARG, SVt_PV);
3288             SvGROW(TARG, (len * 2) + 1);
3289             (void)SvPOK_only(TARG);
3290             d = (U8*)SvPVX(TARG);
3291             send = s + len;
3292             if (IN_LOCALE_RUNTIME) {
3293                 TAINT;
3294                 SvTAINTED_on(TARG);
3295                 while (s < send) {
3296                     d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3297                     s += ulen;
3298                 }
3299             }
3300             else {
3301                 while (s < send) {
3302                     d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3303                     s += UTF8SKIP(s);
3304                 }
3305             }
3306             *d = '\0';
3307             SvUTF8_on(TARG);
3308             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3309             SETs(TARG);
3310         }
3311     }
3312     else {
3313         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3314             dTARGET;
3315             SvUTF8_off(TARG);                           /* decontaminate */
3316             sv_setsv(TARG, sv);
3317             sv = TARG;
3318             SETs(sv);
3319         }
3320         s = (U8*)SvPV_force(sv, len);
3321         if (len) {
3322             register U8 *send = s + len;
3323
3324             if (IN_LOCALE_RUNTIME) {
3325                 TAINT;
3326                 SvTAINTED_on(sv);
3327                 for (; s < send; s++)
3328                     *s = toUPPER_LC(*s);
3329             }
3330             else {
3331                 for (; s < send; s++)
3332                     *s = toUPPER(*s);
3333             }
3334         }
3335     }
3336     if (SvSMAGICAL(sv))
3337         mg_set(sv);
3338     RETURN;
3339 }
3340
3341 PP(pp_lc)
3342 {
3343     dSP;
3344     SV *sv = TOPs;
3345     register U8 *s;
3346     STRLEN len;
3347
3348     if (DO_UTF8(sv)) {
3349         dTARGET;
3350         STRLEN ulen;
3351         register U8 *d;
3352         U8 *send;
3353
3354         s = (U8*)SvPV(sv,len);
3355         if (!len) {
3356             SvUTF8_off(TARG);                           /* decontaminate */
3357             sv_setpvn(TARG, "", 0);
3358             SETs(TARG);
3359         }
3360         else {
3361             (void)SvUPGRADE(TARG, SVt_PV);
3362             SvGROW(TARG, (len * 2) + 1);
3363             (void)SvPOK_only(TARG);
3364             d = (U8*)SvPVX(TARG);
3365             send = s + len;
3366             if (IN_LOCALE_RUNTIME) {
3367                 TAINT;
3368                 SvTAINTED_on(TARG);
3369                 while (s < send) {
3370                     d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3371                     s += ulen;
3372                 }
3373             }
3374             else {
3375                 while (s < send) {
3376                     d = uvchr_to_utf8(d, toLOWER_utf8(s));
3377                     s += UTF8SKIP(s);
3378                 }
3379             }
3380             *d = '\0';
3381             SvUTF8_on(TARG);
3382             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3383             SETs(TARG);
3384         }
3385     }
3386     else {
3387         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3388             dTARGET;
3389             SvUTF8_off(TARG);                           /* decontaminate */
3390             sv_setsv(TARG, sv);
3391             sv = TARG;
3392             SETs(sv);
3393         }
3394
3395         s = (U8*)SvPV_force(sv, len);
3396         if (len) {
3397             register U8 *send = s + len;
3398
3399             if (IN_LOCALE_RUNTIME) {
3400                 TAINT;
3401                 SvTAINTED_on(sv);
3402                 for (; s < send; s++)
3403                     *s = toLOWER_LC(*s);
3404             }
3405             else {
3406                 for (; s < send; s++)
3407                     *s = toLOWER(*s);
3408             }
3409         }
3410     }
3411     if (SvSMAGICAL(sv))
3412         mg_set(sv);
3413     RETURN;
3414 }
3415
3416 PP(pp_quotemeta)
3417 {
3418     dSP; dTARGET;
3419     SV *sv = TOPs;
3420     STRLEN len;
3421     register char *s = SvPV(sv,len);
3422     register char *d;
3423
3424     SvUTF8_off(TARG);                           /* decontaminate */
3425     if (len) {
3426         (void)SvUPGRADE(TARG, SVt_PV);
3427         SvGROW(TARG, (len * 2) + 1);
3428         d = SvPVX(TARG);
3429         if (DO_UTF8(sv)) {
3430             while (len) {
3431                 if (UTF8_IS_CONTINUED(*s)) {
3432                     STRLEN ulen = UTF8SKIP(s);
3433                     if (ulen > len)
3434                         ulen = len;
3435                     len -= ulen;
3436                     while (ulen--)
3437                         *d++ = *s++;
3438                 }
3439                 else {
3440                     if (!isALNUM(*s))
3441                         *d++ = '\\';
3442                     *d++ = *s++;
3443                     len--;
3444                 }
3445             }
3446             SvUTF8_on(TARG);
3447         }
3448         else {
3449             while (len--) {
3450                 if (!isALNUM(*s))
3451                     *d++ = '\\';
3452                 *d++ = *s++;
3453             }
3454         }
3455         *d = '\0';
3456         SvCUR_set(TARG, d - SvPVX(TARG));
3457         (void)SvPOK_only_UTF8(TARG);
3458     }
3459     else
3460         sv_setpvn(TARG, s, len);
3461     SETs(TARG);
3462     if (SvSMAGICAL(TARG))
3463         mg_set(TARG);
3464     RETURN;
3465 }
3466
3467 /* Arrays. */
3468
3469 PP(pp_aslice)
3470 {
3471     dSP; dMARK; dORIGMARK;
3472     register SV** svp;
3473     register AV* av = (AV*)POPs;
3474     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3475     I32 arybase = PL_curcop->cop_arybase;
3476     I32 elem;
3477
3478     if (SvTYPE(av) == SVt_PVAV) {
3479         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3480             I32 max = -1;
3481             for (svp = MARK + 1; svp <= SP; svp++) {
3482                 elem = SvIVx(*svp);
3483                 if (elem > max)
3484                     max = elem;
3485             }
3486             if (max > AvMAX(av))
3487                 av_extend(av, max);
3488         }
3489         while (++MARK <= SP) {
3490             elem = SvIVx(*MARK);
3491
3492             if (elem > 0)
3493                 elem -= arybase;
3494             svp = av_fetch(av, elem, lval);
3495             if (lval) {
3496                 if (!svp || *svp == &PL_sv_undef)
3497                     DIE(aTHX_ PL_no_aelem, elem);
3498                 if (PL_op->op_private & OPpLVAL_INTRO)
3499                     save_aelem(av, elem, svp);
3500             }
3501             *MARK = svp ? *svp : &PL_sv_undef;
3502         }
3503     }
3504     if (GIMME != G_ARRAY) {
3505         MARK = ORIGMARK;
3506         *++MARK = *SP;
3507         SP = MARK;
3508     }
3509     RETURN;
3510 }
3511
3512 /* Associative arrays. */
3513
3514 PP(pp_each)
3515 {
3516     dSP;
3517     HV *hash = (HV*)POPs;
3518     HE *entry;
3519     I32 gimme = GIMME_V;
3520     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3521
3522     PUTBACK;
3523     /* might clobber stack_sp */
3524     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3525     SPAGAIN;
3526
3527     EXTEND(SP, 2);
3528     if (entry) {
3529         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
3530         if (gimme == G_ARRAY) {
3531             SV *val;
3532             PUTBACK;
3533             /* might clobber stack_sp */
3534             val = realhv ?
3535                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3536             SPAGAIN;
3537             PUSHs(val);
3538         }
3539     }
3540     else if (gimme == G_SCALAR)
3541         RETPUSHUNDEF;
3542
3543     RETURN;
3544 }
3545
3546 PP(pp_values)
3547 {
3548     return do_kv();
3549 }
3550
3551 PP(pp_keys)
3552 {
3553     return do_kv();
3554 }
3555
3556 PP(pp_delete)
3557 {
3558     dSP;
3559     I32 gimme = GIMME_V;
3560     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3561     SV *sv;
3562     HV *hv;
3563
3564     if (PL_op->op_private & OPpSLICE) {
3565         dMARK; dORIGMARK;
3566         U32 hvtype;
3567         hv = (HV*)POPs;
3568         hvtype = SvTYPE(hv);
3569         if (hvtype == SVt_PVHV) {                       /* hash element */
3570             while (++MARK <= SP) {
3571                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3572                 *MARK = sv ? sv : &PL_sv_undef;
3573             }
3574         }
3575         else if (hvtype == SVt_PVAV) {
3576             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
3577                 while (++MARK <= SP) {
3578                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3579                     *MARK = sv ? sv : &PL_sv_undef;
3580                 }
3581             }
3582             else {                                      /* pseudo-hash element */
3583                 while (++MARK <= SP) {
3584                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3585                     *MARK = sv ? sv : &PL_sv_undef;
3586                 }
3587             }
3588         }
3589         else
3590             DIE(aTHX_ "Not a HASH reference");
3591         if (discard)
3592             SP = ORIGMARK;
3593         else if (gimme == G_SCALAR) {
3594             MARK = ORIGMARK;
3595             *++MARK = *SP;
3596             SP = MARK;
3597         }
3598     }
3599     else {
3600         SV *keysv = POPs;
3601         hv = (HV*)POPs;
3602         if (SvTYPE(hv) == SVt_PVHV)
3603             sv = hv_delete_ent(hv, keysv, discard, 0);
3604         else if (SvTYPE(hv) == SVt_PVAV) {
3605             if (PL_op->op_flags & OPf_SPECIAL)
3606                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3607             else
3608                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3609         }
3610         else
3611             DIE(aTHX_ "Not a HASH reference");
3612         if (!sv)
3613             sv = &PL_sv_undef;
3614         if (!discard)
3615             PUSHs(sv);
3616     }
3617     RETURN;
3618 }
3619
3620 PP(pp_exists)
3621 {
3622     dSP;
3623     SV *tmpsv;
3624     HV *hv;
3625
3626     if (PL_op->op_private & OPpEXISTS_SUB) {
3627         GV *gv;
3628         CV *cv;
3629         SV *sv = POPs;
3630         cv = sv_2cv(sv, &hv, &gv, FALSE);
3631         if (cv)
3632             RETPUSHYES;
3633         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3634             RETPUSHYES;
3635         RETPUSHNO;
3636     }
3637     tmpsv = POPs;
3638     hv = (HV*)POPs;
3639     if (SvTYPE(hv) == SVt_PVHV) {
3640         if (hv_exists_ent(hv, tmpsv, 0))
3641             RETPUSHYES;
3642     }
3643     else if (SvTYPE(hv) == SVt_PVAV) {
3644         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3645             if (av_exists((AV*)hv, SvIV(tmpsv)))
3646                 RETPUSHYES;
3647         }
3648         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
3649             RETPUSHYES;
3650     }
3651     else {
3652         DIE(aTHX_ "Not a HASH reference");
3653     }
3654     RETPUSHNO;
3655 }
3656
3657 PP(pp_hslice)
3658 {
3659     dSP; dMARK; dORIGMARK;
3660     register HV *hv = (HV*)POPs;
3661     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3662     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3663
3664     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3665         DIE(aTHX_ "Can't localize pseudo-hash element");
3666
3667     if (realhv || SvTYPE(hv) == SVt_PVAV) {
3668         while (++MARK <= SP) {
3669             SV *keysv = *MARK;
3670             SV **svp;
3671             I32 preeminent = SvRMAGICAL(hv) ? 1 :
3672                                 realhv ? hv_exists_ent(hv, keysv, 0)
3673                                        : avhv_exists_ent((AV*)hv, keysv, 0);
3674             if (realhv) {
3675                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3676                 svp = he ? &HeVAL(he) : 0;
3677             }
3678             else {
3679                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3680             }
3681             if (lval) {
3682                 if (!svp || *svp == &PL_sv_undef) {
3683                     STRLEN n_a;
3684                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3685                 }
3686                 if (PL_op->op_private & OPpLVAL_INTRO) {
3687                     if (preeminent)
3688                         save_helem(hv, keysv, svp);
3689                     else {
3690                         STRLEN keylen;
3691                         char *key = SvPV(keysv, keylen);
3692                         SAVEDELETE(hv, savepvn(key,keylen), keylen);
3693                     }
3694                 }
3695             }
3696             *MARK = svp ? *svp : &PL_sv_undef;
3697         }
3698     }
3699     if (GIMME != G_ARRAY) {
3700         MARK = ORIGMARK;
3701         *++MARK = *SP;
3702         SP = MARK;
3703     }
3704     RETURN;
3705 }
3706
3707 /* List operators. */
3708
3709 PP(pp_list)
3710 {
3711     dSP; dMARK;
3712     if (GIMME != G_ARRAY) {
3713         if (++MARK <= SP)
3714             *MARK = *SP;                /* unwanted list, return last item */
3715         else
3716             *MARK = &PL_sv_undef;
3717         SP = MARK;
3718     }
3719     RETURN;
3720 }
3721
3722 PP(pp_lslice)
3723 {
3724     dSP;
3725     SV **lastrelem = PL_stack_sp;
3726     SV **lastlelem = PL_stack_base + POPMARK;
3727     SV **firstlelem = PL_stack_base + POPMARK + 1;
3728     register SV **firstrelem = lastlelem + 1;
3729     I32 arybase = PL_curcop->cop_arybase;
3730     I32 lval = PL_op->op_flags & OPf_MOD;
3731     I32 is_something_there = lval;
3732
3733     register I32 max = lastrelem - lastlelem;
3734     register SV **lelem;
3735     register I32 ix;
3736
3737     if (GIMME != G_ARRAY) {
3738         ix = SvIVx(*lastlelem);
3739         if (ix < 0)
3740             ix += max;
3741         else
3742             ix -= arybase;
3743         if (ix < 0 || ix >= max)
3744             *firstlelem = &PL_sv_undef;
3745         else
3746             *firstlelem = firstrelem[ix];
3747         SP = firstlelem;
3748         RETURN;
3749     }
3750
3751     if (max == 0) {
3752         SP = firstlelem - 1;
3753         RETURN;
3754     }
3755
3756     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3757         ix = SvIVx(*lelem);
3758         if (ix < 0)
3759             ix += max;
3760         else
3761             ix -= arybase;
3762         if (ix < 0 || ix >= max)
3763             *lelem = &PL_sv_undef;
3764         else {
3765             is_something_there = TRUE;
3766             if (!(*lelem = firstrelem[ix]))
3767                 *lelem = &PL_sv_undef;
3768         }
3769     }
3770     if (is_something_there)
3771         SP = lastlelem;
3772     else
3773         SP = firstlelem - 1;
3774     RETURN;
3775 }
3776
3777 PP(pp_anonlist)
3778 {
3779     dSP; dMARK; dORIGMARK;
3780     I32 items = SP - MARK;
3781     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3782     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3783     XPUSHs(av);
3784     RETURN;
3785 }
3786
3787 PP(pp_anonhash)
3788 {
3789     dSP; dMARK; dORIGMARK;
3790     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3791
3792     while (MARK < SP) {
3793         SV* key = *++MARK;
3794         SV *val = NEWSV(46, 0);
3795         if (MARK < SP)
3796             sv_setsv(val, *++MARK);
3797         else if (ckWARN(WARN_MISC))
3798             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3799         (void)hv_store_ent(hv,key,val,0);
3800     }
3801     SP = ORIGMARK;
3802     XPUSHs((SV*)hv);
3803     RETURN;
3804 }
3805
3806 PP(pp_splice)
3807 {
3808     dSP; dMARK; dORIGMARK;
3809     register AV *ary = (AV*)*++MARK;
3810     register SV **src;
3811     register SV **dst;
3812     register I32 i;
3813     register I32 offset;
3814     register I32 length;
3815     I32 newlen;
3816     I32 after;
3817     I32 diff;
3818     SV **tmparyval = 0;
3819     MAGIC *mg;
3820
3821     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3822         *MARK-- = SvTIED_obj((SV*)ary, mg);
3823         PUSHMARK(MARK);
3824         PUTBACK;
3825         ENTER;
3826         call_method("SPLICE",GIMME_V);
3827         LEAVE;
3828         SPAGAIN;
3829         RETURN;
3830     }
3831
3832     SP++;
3833
3834     if (++MARK < SP) {
3835         offset = i = SvIVx(*MARK);
3836         if (offset < 0)
3837             offset += AvFILLp(ary) + 1;
3838         else
3839             offset -= PL_curcop->cop_arybase;
3840         if (offset < 0)
3841             DIE(aTHX_ PL_no_aelem, i);
3842         if (++MARK < SP) {
3843             length = SvIVx(*MARK++);
3844             if (length < 0) {
3845                 length += AvFILLp(ary) - offset + 1;
3846                 if (length < 0)
3847                     length = 0;
3848             }
3849         }
3850         else
3851             length = AvMAX(ary) + 1;            /* close enough to infinity */
3852     }
3853     else {
3854         offset = 0;
3855         length = AvMAX(ary) + 1;
3856     }
3857     if (offset > AvFILLp(ary) + 1)
3858         offset = AvFILLp(ary) + 1;
3859     after = AvFILLp(ary) + 1 - (offset + length);
3860     if (after < 0) {                            /* not that much array */
3861         length += after;                        /* offset+length now in array */
3862         after = 0;
3863         if (!AvALLOC(ary))
3864             av_extend(ary, 0);
3865     }
3866
3867     /* At this point, MARK .. SP-1 is our new LIST */
3868
3869     newlen = SP - MARK;
3870     diff = newlen - length;
3871     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3872         av_reify(ary);
3873
3874     if (diff < 0) {                             /* shrinking the area */
3875         if (newlen) {
3876             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3877             Copy(MARK, tmparyval, newlen, SV*);
3878         }
3879
3880         MARK = ORIGMARK + 1;
3881         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3882             MEXTEND(MARK, length);
3883             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3884             if (AvREAL(ary)) {
3885                 EXTEND_MORTAL(length);
3886                 for (i = length, dst = MARK; i; i--) {
3887                     sv_2mortal(*dst);   /* free them eventualy */
3888                     dst++;
3889                 }
3890             }
3891             MARK += length - 1;
3892         }
3893         else {
3894             *MARK = AvARRAY(ary)[offset+length-1];
3895             if (AvREAL(ary)) {
3896                 sv_2mortal(*MARK);
3897                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3898                     SvREFCNT_dec(*dst++);       /* free them now */
3899             }
3900         }
3901         AvFILLp(ary) += diff;
3902
3903         /* pull up or down? */
3904
3905         if (offset < after) {                   /* easier to pull up */
3906             if (offset) {                       /* esp. if nothing to pull */
3907                 src = &AvARRAY(ary)[offset-1];
3908                 dst = src - diff;               /* diff is negative */
3909                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3910                     *dst-- = *src--;
3911             }
3912             dst = AvARRAY(ary);
3913             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3914             AvMAX(ary) += diff;
3915         }
3916         else {
3917             if (after) {                        /* anything to pull down? */
3918                 src = AvARRAY(ary) + offset + length;
3919                 dst = src + diff;               /* diff is negative */
3920                 Move(src, dst, after, SV*);
3921             }
3922             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3923                                                 /* avoid later double free */
3924         }
3925         i = -diff;
3926         while (i)
3927             dst[--i] = &PL_sv_undef;
3928
3929         if (newlen) {
3930             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3931               newlen; newlen--) {
3932                 *dst = NEWSV(46, 0);
3933                 sv_setsv(*dst++, *src++);
3934             }
3935             Safefree(tmparyval);
3936         }
3937     }
3938     else {                                      /* no, expanding (or same) */
3939         if (length) {
3940             New(452, tmparyval, length, SV*);   /* so remember deletion */
3941             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3942         }
3943
3944         if (diff > 0) {                         /* expanding */
3945
3946             /* push up or down? */
3947
3948             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3949                 if (offset) {
3950                     src = AvARRAY(ary);
3951                     dst = src - diff;
3952                     Move(src, dst, offset, SV*);
3953                 }
3954                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3955                 AvMAX(ary) += diff;
3956                 AvFILLp(ary) += diff;
3957             }
3958             else {
3959                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3960                     av_extend(ary, AvFILLp(ary) + diff);
3961                 AvFILLp(ary) += diff;
3962
3963                 if (after) {
3964                     dst = AvARRAY(ary) + AvFILLp(ary);
3965                     src = dst - diff;
3966                     for (i = after; i; i--) {
3967                         *dst-- = *src--;
3968                     }
3969                 }
3970             }
3971         }
3972
3973         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3974             *dst = NEWSV(46, 0);
3975             sv_setsv(*dst++, *src++);
3976         }
3977         MARK = ORIGMARK + 1;
3978         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3979             if (length) {
3980                 Copy(tmparyval, MARK, length, SV*);
3981                 if (AvREAL(ary)) {
3982                     EXTEND_MORTAL(length);
3983                     for (i = length, dst = MARK; i; i--) {
3984                         sv_2mortal(*dst);       /* free them eventualy */
3985                         dst++;
3986                     }
3987                 }
3988                 Safefree(tmparyval);
3989             }
3990             MARK += length - 1;
3991         }
3992         else if (length--) {
3993             *MARK = tmparyval[length];
3994             if (AvREAL(ary)) {
3995                 sv_2mortal(*MARK);
3996                 while (length-- > 0)
3997                     SvREFCNT_dec(tmparyval[length]);
3998             }
3999             Safefree(tmparyval);
4000         }
4001         else
4002             *MARK = &PL_sv_undef;
4003     }
4004     SP = MARK;
4005     RETURN;
4006 }
4007
4008 PP(pp_push)
4009 {
4010     dSP; dMARK; dORIGMARK; dTARGET;
4011     register AV *ary = (AV*)*++MARK;
4012     register SV *sv = &PL_sv_undef;
4013     MAGIC *mg;
4014
4015     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4016         *MARK-- = SvTIED_obj((SV*)ary, mg);
4017         PUSHMARK(MARK);
4018         PUTBACK;
4019         ENTER;
4020         call_method("PUSH",G_SCALAR|G_DISCARD);
4021         LEAVE;
4022         SPAGAIN;
4023     }
4024     else {
4025         /* Why no pre-extend of ary here ? */
4026         for (++MARK; MARK <= SP; MARK++) {
4027             sv = NEWSV(51, 0);
4028             if (*MARK)
4029                 sv_setsv(sv, *MARK);
4030             av_push(ary, sv);
4031         }
4032     }
4033     SP = ORIGMARK;
4034     PUSHi( AvFILL(ary) + 1 );
4035     RETURN;
4036 }
4037
4038 PP(pp_pop)
4039 {
4040     dSP;
4041     AV *av = (AV*)POPs;
4042     SV *sv = av_pop(av);
4043     if (AvREAL(av))
4044         (void)sv_2mortal(sv);
4045     PUSHs(sv);
4046     RETURN;
4047 }
4048
4049 PP(pp_shift)
4050 {
4051     dSP;
4052     AV *av = (AV*)POPs;
4053     SV *sv = av_shift(av);
4054     EXTEND(SP, 1);
4055     if (!sv)
4056         RETPUSHUNDEF;
4057     if (AvREAL(av))
4058         (void)sv_2mortal(sv);
4059     PUSHs(sv);
4060     RETURN;
4061 }
4062
4063 PP(pp_unshift)
4064 {
4065     dSP; dMARK; dORIGMARK; dTARGET;
4066     register AV *ary = (AV*)*++MARK;
4067     register SV *sv;
4068     register I32 i = 0;
4069     MAGIC *mg;
4070
4071     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4072         *MARK-- = SvTIED_obj((SV*)ary, mg);
4073         PUSHMARK(MARK);
4074         PUTBACK;
4075         ENTER;
4076         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4077         LEAVE;
4078         SPAGAIN;
4079     }
4080     else {
4081         av_unshift(ary, SP - MARK);
4082         while (MARK < SP) {
4083             sv = NEWSV(27, 0);
4084             sv_setsv(sv, *++MARK);
4085             (void)av_store(ary, i++, sv);
4086         }
4087     }
4088     SP = ORIGMARK;
4089     PUSHi( AvFILL(ary) + 1 );
4090     RETURN;
4091 }
4092
4093 PP(pp_reverse)
4094 {
4095     dSP; dMARK;
4096     register SV *tmp;
4097     SV **oldsp = SP;
4098
4099     if (GIMME == G_ARRAY) {
4100         MARK++;
4101         while (MARK < SP) {
4102             tmp = *MARK;
4103             *MARK++ = *SP;
4104             *SP-- = tmp;
4105         }
4106         /* safe as long as stack cannot get extended in the above */
4107         SP = oldsp;
4108     }
4109     else {
4110         register char *up;
4111         register char *down;
4112         register I32 tmp;
4113         dTARGET;
4114         STRLEN len;
4115
4116         SvUTF8_off(TARG);                               /* decontaminate */
4117         if (SP - MARK > 1)
4118             do_join(TARG, &PL_sv_no, MARK, SP);
4119         else
4120             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4121         up = SvPV_force(TARG, len);
4122         if (len > 1) {
4123             if (DO_UTF8(TARG)) {        /* first reverse each character */
4124                 U8* s = (U8*)SvPVX(TARG);
4125                 U8* send = (U8*)(s + len);
4126                 while (s < send) {
4127                     if (UTF8_IS_INVARIANT(*s)) {
4128                         s++;
4129                         continue;
4130                     }
4131                     else {
4132                         if (!utf8_to_uvchr(s, 0))
4133                             break;
4134                         up = (char*)s;
4135                         s += UTF8SKIP(s);
4136                         down = (char*)(s - 1);
4137                         /* reverse this character */
4138                         while (down > up) {
4139                             tmp = *up;
4140                             *up++ = *down;
4141                             *down-- = tmp;
4142                         }
4143                     }
4144                 }
4145                 up = SvPVX(TARG);
4146             }
4147             down = SvPVX(TARG) + len - 1;
4148             while (down > up) {
4149                 tmp = *up;
4150                 *up++ = *down;
4151                 *down-- = tmp;
4152             }
4153             (void)SvPOK_only_UTF8(TARG);
4154         }
4155         SP = MARK + 1;
4156         SETTARG;
4157     }
4158     RETURN;
4159 }
4160
4161 PP(pp_split)
4162 {
4163     dSP; dTARG;
4164     AV *ary;
4165     register IV limit = POPi;                   /* note, negative is forever */
4166     SV *sv = POPs;
4167     STRLEN len;
4168     register char *s = SvPV(sv, len);
4169     bool do_utf8 = DO_UTF8(sv);
4170     char *strend = s + len;
4171     register PMOP *pm;
4172     register REGEXP *rx;
4173     register SV *dstr;
4174     register char *m;
4175     I32 iters = 0;
4176     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4177     I32 maxiters = slen + 10;
4178     I32 i;
4179     char *orig;
4180     I32 origlimit = limit;
4181     I32 realarray = 0;
4182     I32 base;
4183     AV *oldstack = PL_curstack;
4184     I32 gimme = GIMME_V;
4185     I32 oldsave = PL_savestack_ix;
4186     I32 make_mortal = 1;
4187     MAGIC *mg = (MAGIC *) NULL;
4188
4189 #ifdef DEBUGGING
4190     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4191 #else
4192     pm = (PMOP*)POPs;
4193 #endif
4194     if (!pm || !s)
4195         DIE(aTHX_ "panic: pp_split");
4196     rx = PM_GETRE(pm);
4197
4198     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4199              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4200
4201     PL_reg_match_utf8 = do_utf8;
4202
4203     if (pm->op_pmreplroot) {
4204 #ifdef USE_ITHREADS
4205         ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4206 #else
4207         ary = GvAVn((GV*)pm->op_pmreplroot);
4208 #endif
4209     }
4210     else if (gimme != G_ARRAY)
4211 #ifdef USE_5005THREADS
4212         ary = (AV*)PL_curpad[0];
4213 #else
4214         ary = GvAVn(PL_defgv);
4215 #endif /* USE_5005THREADS */
4216     else
4217         ary = Nullav;
4218     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4219         realarray = 1;
4220         PUTBACK;
4221         av_extend(ary,0);
4222         av_clear(ary);
4223         SPAGAIN;
4224         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4225             PUSHMARK(SP);
4226             XPUSHs(SvTIED_obj((SV*)ary, mg));
4227         }
4228         else {
4229             if (!AvREAL(ary)) {
4230                 AvREAL_on(ary);
4231                 AvREIFY_off(ary);
4232                 for (i = AvFILLp(ary); i >= 0; i--)
4233                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4234             }
4235             /* temporarily switch stacks */
4236             SWITCHSTACK(PL_curstack, ary);
4237             make_mortal = 0;
4238         }
4239     }
4240     base = SP - PL_stack_base;
4241     orig = s;
4242     if (pm->op_pmflags & PMf_SKIPWHITE) {
4243         if (pm->op_pmflags & PMf_LOCALE) {
4244             while (isSPACE_LC(*s))
4245                 s++;
4246         }
4247         else {
4248             while (isSPACE(*s))
4249                 s++;
4250         }
4251     }
4252     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4253         SAVEINT(PL_multiline);
4254         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4255     }
4256
4257     if (!limit)
4258         limit = maxiters + 2;
4259     if (pm->op_pmflags & PMf_WHITE) {
4260         while (--limit) {
4261             m = s;
4262             while (m < strend &&
4263                    !((pm->op_pmflags & PMf_LOCALE)
4264                      ? isSPACE_LC(*m) : isSPACE(*m)))
4265                 ++m;
4266             if (m >= strend)
4267                 break;
4268
4269             dstr = NEWSV(30, m-s);
4270             sv_setpvn(dstr, s, m-s);
4271             if (make_mortal)
4272                 sv_2mortal(dstr);
4273             if (do_utf8)
4274                 (void)SvUTF8_on(dstr);
4275             XPUSHs(dstr);
4276
4277             s = m + 1;
4278             while (s < strend &&
4279                    ((pm->op_pmflags & PMf_LOCALE)
4280                     ? isSPACE_LC(*s) : isSPACE(*s)))
4281                 ++s;
4282         }
4283     }
4284     else if (strEQ("^", rx->precomp)) {
4285         while (--limit) {
4286             /*SUPPRESS 530*/
4287             for (m = s; m < strend && *m != '\n'; m++) ;
4288             m++;
4289             if (m >= strend)
4290                 break;
4291             dstr = NEWSV(30, m-s);
4292             sv_setpvn(dstr, s, m-s);
4293             if (make_mortal)
4294                 sv_2mortal(dstr);
4295             if (do_utf8)
4296                 (void)SvUTF8_on(dstr);
4297             XPUSHs(dstr);
4298             s = m;
4299         }
4300     }
4301     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4302              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4303              && (rx->reganch & ROPT_CHECK_ALL)
4304              && !(rx->reganch & ROPT_ANCH)) {
4305         int tail = (rx->reganch & RE_INTUIT_TAIL);
4306         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4307
4308         len = rx->minlen;
4309         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4310             STRLEN n_a;
4311             char c = *SvPV(csv, n_a);
4312             while (--limit) {
4313                 /*SUPPRESS 530*/
4314                 for (m = s; m < strend && *m != c; m++) ;
4315                 if (m >= strend)
4316                     break;
4317                 dstr = NEWSV(30, m-s);
4318                 sv_setpvn(dstr, s, m-s);
4319                 if (make_mortal)
4320                     sv_2mortal(dstr);
4321                 if (do_utf8)
4322                     (void)SvUTF8_on(dstr);
4323                 XPUSHs(dstr);
4324                 /* The rx->minlen is in characters but we want to step
4325                  * s ahead by bytes. */
4326                 if (do_utf8)
4327                     s = (char*)utf8_hop((U8*)m, len);
4328                 else
4329                     s = m + len; /* Fake \n at the end */
4330             }
4331         }
4332         else {
4333 #ifndef lint
4334             while (s < strend && --limit &&
4335               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4336                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4337 #endif
4338             {
4339                 dstr = NEWSV(31, m-s);
4340                 sv_setpvn(dstr, s, m-s);
4341                 if (make_mortal)
4342                     sv_2mortal(dstr);
4343                 if (do_utf8)
4344                     (void)SvUTF8_on(dstr);
4345                 XPUSHs(dstr);
4346                 /* The rx->minlen is in characters but we want to step
4347                  * s ahead by bytes. */
4348                 if (do_utf8)
4349                     s = (char*)utf8_hop((U8*)m, len);
4350                 else
4351                     s = m + len; /* Fake \n at the end */
4352             }
4353         }
4354     }
4355     else {
4356         maxiters += slen * rx->nparens;
4357         while (s < strend && --limit
4358 /*             && (!rx->check_substr
4359                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4360                                                  0, NULL))))
4361 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4362                               1 /* minend */, sv, NULL, 0))
4363         {
4364             TAINT_IF(RX_MATCH_TAINTED(rx));
4365             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4366                 m = s;
4367                 s = orig;
4368                 orig = rx->subbeg;
4369                 s = orig + (m - s);
4370                 strend = s + (strend - m);
4371             }
4372             m = rx->startp[0] + orig;
4373             dstr = NEWSV(32, m-s);
4374             sv_setpvn(dstr, s, m-s);
4375             if (make_mortal)
4376                 sv_2mortal(dstr);
4377             if (do_utf8)
4378                 (void)SvUTF8_on(dstr);
4379             XPUSHs(dstr);
4380             if (rx->nparens) {
4381                 for (i = 1; i <= rx->nparens; i++) {
4382                     s = rx->startp[i] + orig;
4383                     m = rx->endp[i] + orig;
4384
4385                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4386                        parens that didn't match -- they should be set to
4387                        undef, not the empty string */
4388                     if (m >= orig && s >= orig) {
4389                         dstr = NEWSV(33, m-s);
4390                         sv_setpvn(dstr, s, m-s);
4391                     }
4392                     else
4393                         dstr = &PL_sv_undef;  /* undef, not "" */
4394                     if (make_mortal)
4395                         sv_2mortal(dstr);
4396                     if (do_utf8)
4397                         (void)SvUTF8_on(dstr);
4398                     XPUSHs(dstr);
4399                 }
4400             }
4401             s = rx->endp[0] + orig;
4402         }
4403     }
4404
4405     LEAVE_SCOPE(oldsave);
4406     iters = (SP - PL_stack_base) - base;
4407     if (iters > maxiters)
4408         DIE(aTHX_ "Split loop");
4409
4410     /* keep field after final delim? */
4411     if (s < strend || (iters && origlimit)) {
4412         STRLEN l = strend - s;
4413         dstr = NEWSV(34, l);
4414         sv_setpvn(dstr, s, l);
4415         if (make_mortal)
4416             sv_2mortal(dstr);
4417         if (do_utf8)
4418             (void)SvUTF8_on(dstr);
4419         XPUSHs(dstr);
4420         iters++;
4421     }
4422     else if (!origlimit) {
4423         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4424             iters--, SP--;
4425     }
4426
4427     if (realarray) {
4428         if (!mg) {
4429             SWITCHSTACK(ary, oldstack);
4430             if (SvSMAGICAL(ary)) {
4431                 PUTBACK;
4432                 mg_set((SV*)ary);
4433                 SPAGAIN;
4434             }
4435             if (gimme == G_ARRAY) {
4436                 EXTEND(SP, iters);
4437                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4438                 SP += iters;
4439                 RETURN;
4440             }
4441         }
4442         else {
4443             PUTBACK;
4444             ENTER;
4445             call_method("PUSH",G_SCALAR|G_DISCARD);
4446             LEAVE;
4447             SPAGAIN;
4448             if (gimme == G_ARRAY) {
4449                 /* EXTEND should not be needed - we just popped them */
4450                 EXTEND(SP, iters);
4451                 for (i=0; i < iters; i++) {
4452                     SV **svp = av_fetch(ary, i, FALSE);
4453                     PUSHs((svp) ? *svp : &PL_sv_undef);
4454                 }
4455                 RETURN;
4456             }
4457         }
4458     }
4459     else {
4460         if (gimme == G_ARRAY)
4461             RETURN;
4462     }
4463     if (iters || !pm->op_pmreplroot) {
4464         GETTARGET;
4465         PUSHi(iters);
4466         RETURN;
4467     }
4468     RETPUSHUNDEF;
4469 }
4470
4471 #ifdef USE_5005THREADS
4472 void
4473 Perl_unlock_condpair(pTHX_ void *svv)
4474 {
4475     MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4476
4477     if (!mg)
4478         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4479     MUTEX_LOCK(MgMUTEXP(mg));
4480     if (MgOWNER(mg) != thr)
4481         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4482     MgOWNER(mg) = 0;
4483     COND_SIGNAL(MgOWNERCONDP(mg));
4484     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4485                           PTR2UV(thr), PTR2UV(svv)));
4486     MUTEX_UNLOCK(MgMUTEXP(mg));
4487 }
4488 #endif /* USE_5005THREADS */
4489
4490 PP(pp_lock)
4491 {
4492     dSP;
4493     dTOPss;
4494     SV *retsv = sv;
4495 #ifdef USE_5005THREADS
4496     sv_lock(sv);
4497 #endif /* USE_5005THREADS */
4498 #ifdef USE_ITHREADS
4499     shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4500     if(ssv)
4501         Perl_sharedsv_lock(aTHX_ ssv);
4502 #endif /* USE_ITHREADS */
4503     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4504         || SvTYPE(retsv) == SVt_PVCV) {
4505         retsv = refto(retsv);
4506     }
4507     SETs(retsv);
4508     RETURN;
4509 }
4510
4511 PP(pp_threadsv)
4512 {
4513 #ifdef USE_5005THREADS
4514     dSP;
4515     EXTEND(SP, 1);
4516     if (PL_op->op_private & OPpLVAL_INTRO)
4517         PUSHs(*save_threadsv(PL_op->op_targ));
4518     else
4519         PUSHs(THREADSV(PL_op->op_targ));
4520     RETURN;
4521 #else
4522     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4523 #endif /* USE_5005THREADS */
4524 }