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