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 PP(pp_int)
2652 {
2653     dSP; dTARGET; tryAMAGICun(int);
2654     {
2655       NV value;
2656       IV iv = TOPi; /* attempt to convert to IV if possible. */
2657       /* XXX it's arguable that compiler casting to IV might be subtly
2658          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2659          else preferring IV has introduced a subtle behaviour change bug. OTOH
2660          relying on floating point to be accurate is a bug.  */
2661
2662       if (SvIOK(TOPs)) {
2663         if (SvIsUV(TOPs)) {
2664             UV uv = TOPu;
2665             SETu(uv);
2666         } else
2667             SETi(iv);
2668       } else {
2669           value = TOPn;
2670           if (value >= 0.0) {
2671               if (value < (NV)UV_MAX + 0.5) {
2672                   SETu(U_V(value));
2673               } else {
2674 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2675 #   ifdef HAS_MODFL_POW32_BUG
2676 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2677                 {
2678                     NV offset = Perl_modf(value, &value);
2679                     (void)Perl_modf(offset, &offset);
2680                     value += offset;
2681                 }
2682 #   else
2683                   (void)Perl_modf(value, &value);
2684 #   endif
2685 #else
2686                   double tmp = (double)value;
2687                   (void)Perl_modf(tmp, &tmp);
2688                   value = (NV)tmp;
2689 #endif
2690                   SETn(value);
2691               }
2692           }
2693           else {
2694               if (value > (NV)IV_MIN - 0.5) {
2695                   SETi(I_V(value));
2696               } else {
2697 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2698 #   ifdef HAS_MODFL_POW32_BUG
2699 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2700                  {
2701                      NV offset = Perl_modf(-value, &value);
2702                      (void)Perl_modf(offset, &offset);
2703                      value += offset;
2704                  }
2705 #   else
2706                   (void)Perl_modf(-value, &value);
2707 #   endif
2708                   value = -value;
2709 #else
2710                   double tmp = (double)value;
2711                   (void)Perl_modf(-tmp, &tmp);
2712                   value = -(NV)tmp;
2713 #endif
2714                   SETn(value);
2715               }
2716           }
2717       }
2718     }
2719     RETURN;
2720 }
2721
2722 PP(pp_abs)
2723 {
2724     dSP; dTARGET; tryAMAGICun(abs);
2725     {
2726       /* This will cache the NV value if string isn't actually integer  */
2727       IV iv = TOPi;
2728
2729       if (SvIOK(TOPs)) {
2730         /* IVX is precise  */
2731         if (SvIsUV(TOPs)) {
2732           SETu(TOPu);   /* force it to be numeric only */
2733         } else {
2734           if (iv >= 0) {
2735             SETi(iv);
2736           } else {
2737             if (iv != IV_MIN) {
2738               SETi(-iv);
2739             } else {
2740               /* 2s complement assumption. Also, not really needed as
2741                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2742               SETu(IV_MIN);
2743             }
2744           }
2745         }
2746       } else{
2747         NV value = TOPn;
2748         if (value < 0.0)
2749           value = -value;
2750         SETn(value);
2751       }
2752     }
2753     RETURN;
2754 }
2755
2756
2757 PP(pp_hex)
2758 {
2759     dSP; dTARGET;
2760     char *tmps;
2761     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2762     STRLEN len;
2763     NV result_nv;
2764     UV result_uv;
2765
2766     tmps = (SvPVx(POPs, len));
2767     result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2768     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2769         XPUSHn(result_nv);
2770     }
2771     else {
2772         XPUSHu(result_uv);
2773     }
2774     RETURN;
2775 }
2776
2777 PP(pp_oct)
2778 {
2779     dSP; dTARGET;
2780     char *tmps;
2781     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2782     STRLEN len;
2783     NV result_nv;
2784     UV result_uv;
2785
2786     tmps = (SvPVx(POPs, len));
2787     while (*tmps && len && isSPACE(*tmps))
2788         tmps++, len--;
2789     if (*tmps == '0')
2790         tmps++, len--;
2791     if (*tmps == 'x')
2792         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2793     else if (*tmps == 'b')
2794         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2795     else
2796         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2797
2798     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2799         XPUSHn(result_nv);
2800     }
2801     else {
2802         XPUSHu(result_uv);
2803     }
2804     RETURN;
2805 }
2806
2807 /* String stuff. */
2808
2809 PP(pp_length)
2810 {
2811     dSP; dTARGET;
2812     SV *sv = TOPs;
2813
2814     if (DO_UTF8(sv))
2815         SETi(sv_len_utf8(sv));
2816     else
2817         SETi(sv_len(sv));
2818     RETURN;
2819 }
2820
2821 PP(pp_substr)
2822 {
2823     dSP; dTARGET;
2824     SV *sv;
2825     I32 len = 0;
2826     STRLEN curlen;
2827     STRLEN utf8_curlen;
2828     I32 pos;
2829     I32 rem;
2830     I32 fail;
2831     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2832     char *tmps;
2833     I32 arybase = PL_curcop->cop_arybase;
2834     SV *repl_sv = NULL;
2835     char *repl = 0;
2836     STRLEN repl_len;
2837     int num_args = PL_op->op_private & 7;
2838     bool repl_need_utf8_upgrade = FALSE;
2839     bool repl_is_utf8 = FALSE;
2840
2841     SvTAINTED_off(TARG);                        /* decontaminate */
2842     SvUTF8_off(TARG);                           /* decontaminate */
2843     if (num_args > 2) {
2844         if (num_args > 3) {
2845             repl_sv = POPs;
2846             repl = SvPV(repl_sv, repl_len);
2847             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2848         }
2849         len = POPi;
2850     }
2851     pos = POPi;
2852     sv = POPs;
2853     PUTBACK;
2854     if (repl_sv) {
2855         if (repl_is_utf8) {
2856             if (!DO_UTF8(sv))
2857                 sv_utf8_upgrade(sv);
2858         }
2859         else if (DO_UTF8(sv))
2860             repl_need_utf8_upgrade = TRUE;
2861     }
2862     tmps = SvPV(sv, curlen);
2863     if (DO_UTF8(sv)) {
2864         utf8_curlen = sv_len_utf8(sv);
2865         if (utf8_curlen == curlen)
2866             utf8_curlen = 0;
2867         else
2868             curlen = utf8_curlen;
2869     }
2870     else
2871         utf8_curlen = 0;
2872
2873     if (pos >= arybase) {
2874         pos -= arybase;
2875         rem = curlen-pos;
2876         fail = rem;
2877         if (num_args > 2) {
2878             if (len < 0) {
2879                 rem += len;
2880                 if (rem < 0)
2881                     rem = 0;
2882             }
2883             else if (rem > len)
2884                      rem = len;
2885         }
2886     }
2887     else {
2888         pos += curlen;
2889         if (num_args < 3)
2890             rem = curlen;
2891         else if (len >= 0) {
2892             rem = pos+len;
2893             if (rem > (I32)curlen)
2894                 rem = curlen;
2895         }
2896         else {
2897             rem = curlen+len;
2898             if (rem < pos)
2899                 rem = pos;
2900         }
2901         if (pos < 0)
2902             pos = 0;
2903         fail = rem;
2904         rem -= pos;
2905     }
2906     if (fail < 0) {
2907         if (lvalue || repl)
2908             Perl_croak(aTHX_ "substr outside of string");
2909         if (ckWARN(WARN_SUBSTR))
2910             Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2911         RETPUSHUNDEF;
2912     }
2913     else {
2914         I32 upos = pos;
2915         I32 urem = rem;
2916         if (utf8_curlen)
2917             sv_pos_u2b(sv, &pos, &rem);
2918         tmps += pos;
2919         sv_setpvn(TARG, tmps, rem);
2920 #ifdef USE_LOCALE_COLLATE
2921         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2922 #endif
2923         if (utf8_curlen)
2924             SvUTF8_on(TARG);
2925         if (repl) {
2926             SV* repl_sv_copy = NULL;
2927
2928             if (repl_need_utf8_upgrade) {
2929                 repl_sv_copy = newSVsv(repl_sv);
2930                 sv_utf8_upgrade(repl_sv_copy);
2931                 repl = SvPV(repl_sv_copy, repl_len);
2932                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2933             }
2934             sv_insert(sv, pos, rem, repl, repl_len);
2935             if (repl_is_utf8)
2936                 SvUTF8_on(sv);
2937             if (repl_sv_copy)
2938                 SvREFCNT_dec(repl_sv_copy);
2939         }
2940         else if (lvalue) {              /* it's an lvalue! */
2941             if (!SvGMAGICAL(sv)) {
2942                 if (SvROK(sv)) {
2943                     STRLEN n_a;
2944                     SvPV_force(sv,n_a);
2945                     if (ckWARN(WARN_SUBSTR))
2946                         Perl_warner(aTHX_ WARN_SUBSTR,
2947                                 "Attempt to use reference as lvalue in substr");
2948                 }
2949                 if (SvOK(sv))           /* is it defined ? */
2950                     (void)SvPOK_only_UTF8(sv);
2951                 else
2952                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2953             }
2954
2955             if (SvTYPE(TARG) < SVt_PVLV) {
2956                 sv_upgrade(TARG, SVt_PVLV);
2957                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2958             }
2959
2960             LvTYPE(TARG) = 'x';
2961             if (LvTARG(TARG) != sv) {
2962                 if (LvTARG(TARG))
2963                     SvREFCNT_dec(LvTARG(TARG));
2964                 LvTARG(TARG) = SvREFCNT_inc(sv);
2965             }
2966             LvTARGOFF(TARG) = upos;
2967             LvTARGLEN(TARG) = urem;
2968         }
2969     }
2970     SPAGAIN;
2971     PUSHs(TARG);                /* avoid SvSETMAGIC here */
2972     RETURN;
2973 }
2974
2975 PP(pp_vec)
2976 {
2977     dSP; dTARGET;
2978     register IV size   = POPi;
2979     register IV offset = POPi;
2980     register SV *src = POPs;
2981     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2982
2983     SvTAINTED_off(TARG);                /* decontaminate */
2984     if (lvalue) {                       /* it's an lvalue! */
2985         if (SvTYPE(TARG) < SVt_PVLV) {
2986             sv_upgrade(TARG, SVt_PVLV);
2987             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2988         }
2989         LvTYPE(TARG) = 'v';
2990         if (LvTARG(TARG) != src) {
2991             if (LvTARG(TARG))
2992                 SvREFCNT_dec(LvTARG(TARG));
2993             LvTARG(TARG) = SvREFCNT_inc(src);
2994         }
2995         LvTARGOFF(TARG) = offset;
2996         LvTARGLEN(TARG) = size;
2997     }
2998
2999     sv_setuv(TARG, do_vecget(src, offset, size));
3000     PUSHs(TARG);
3001     RETURN;
3002 }
3003
3004 PP(pp_index)
3005 {
3006     dSP; dTARGET;
3007     SV *big;
3008     SV *little;
3009     I32 offset;
3010     I32 retval;
3011     char *tmps;
3012     char *tmps2;
3013     STRLEN biglen;
3014     I32 arybase = PL_curcop->cop_arybase;
3015
3016     if (MAXARG < 3)
3017         offset = 0;
3018     else
3019         offset = POPi - arybase;
3020     little = POPs;
3021     big = POPs;
3022     tmps = SvPV(big, biglen);
3023     if (offset > 0 && DO_UTF8(big))
3024         sv_pos_u2b(big, &offset, 0);
3025     if (offset < 0)
3026         offset = 0;
3027     else if (offset > biglen)
3028         offset = biglen;
3029     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3030       (unsigned char*)tmps + biglen, little, 0)))
3031         retval = -1;
3032     else
3033         retval = tmps2 - tmps;
3034     if (retval > 0 && DO_UTF8(big))
3035         sv_pos_b2u(big, &retval);
3036     PUSHi(retval + arybase);
3037     RETURN;
3038 }
3039
3040 PP(pp_rindex)
3041 {
3042     dSP; dTARGET;
3043     SV *big;
3044     SV *little;
3045     STRLEN blen;
3046     STRLEN llen;
3047     I32 offset;
3048     I32 retval;
3049     char *tmps;
3050     char *tmps2;
3051     I32 arybase = PL_curcop->cop_arybase;
3052
3053     if (MAXARG >= 3)
3054         offset = POPi;
3055     little = POPs;
3056     big = POPs;
3057     tmps2 = SvPV(little, llen);
3058     tmps = SvPV(big, blen);
3059     if (MAXARG < 3)
3060         offset = blen;
3061     else {
3062         if (offset > 0 && DO_UTF8(big))
3063             sv_pos_u2b(big, &offset, 0);
3064         offset = offset - arybase + llen;
3065     }
3066     if (offset < 0)
3067         offset = 0;
3068     else if (offset > blen)
3069         offset = blen;
3070     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3071                           tmps2, tmps2 + llen)))
3072         retval = -1;
3073     else
3074         retval = tmps2 - tmps;
3075     if (retval > 0 && DO_UTF8(big))
3076         sv_pos_b2u(big, &retval);
3077     PUSHi(retval + arybase);
3078     RETURN;
3079 }
3080
3081 PP(pp_sprintf)
3082 {
3083     dSP; dMARK; dORIGMARK; dTARGET;
3084     do_sprintf(TARG, SP-MARK, MARK+1);
3085     TAINT_IF(SvTAINTED(TARG));
3086     if (DO_UTF8(*(MARK+1)))
3087         SvUTF8_on(TARG);
3088     SP = ORIGMARK;
3089     PUSHTARG;
3090     RETURN;
3091 }
3092
3093 PP(pp_ord)
3094 {
3095     dSP; dTARGET;
3096     SV *argsv = POPs;
3097     STRLEN len;
3098     U8 *s = (U8*)SvPVx(argsv, len);
3099     SV *tmpsv;
3100
3101     if (PL_encoding && !DO_UTF8(argsv)) {
3102         tmpsv = sv_2mortal(newSVsv(argsv));
3103         s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
3104         argsv = tmpsv;
3105     }
3106
3107     XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3108
3109     RETURN;
3110 }
3111
3112 PP(pp_chr)
3113 {
3114     dSP; dTARGET;
3115     char *tmps;
3116     UV value = POPu;
3117
3118     (void)SvUPGRADE(TARG,SVt_PV);
3119
3120     if (value > 255 && !IN_BYTES) {
3121         SvGROW(TARG, UNISKIP(value)+1);
3122         tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3123         SvCUR_set(TARG, tmps - SvPVX(TARG));
3124         *tmps = '\0';
3125         (void)SvPOK_only(TARG);
3126         SvUTF8_on(TARG);
3127         XPUSHs(TARG);
3128         RETURN;
3129     }
3130
3131     SvGROW(TARG,2);
3132     SvCUR_set(TARG, 1);
3133     tmps = SvPVX(TARG);
3134     *tmps++ = value;
3135     *tmps = '\0';
3136     (void)SvPOK_only(TARG);
3137     if (PL_encoding)
3138         Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3139     XPUSHs(TARG);
3140     RETURN;
3141 }
3142
3143 PP(pp_crypt)
3144 {
3145     dSP; dTARGET;
3146 #ifdef HAS_CRYPT
3147     dPOPTOPssrl;
3148     STRLEN n_a;
3149     STRLEN len;
3150     char *tmps = SvPV(left, len);
3151     char *t    = 0;
3152     if (DO_UTF8(left)) {
3153          /* If Unicode take the crypt() of the low 8 bits
3154           * of the characters of the string. */
3155          char *s    = tmps;
3156          char *send = tmps + len;
3157          STRLEN i   = 0;
3158          Newz(688, t, len, char);
3159          while (s < send) {
3160               t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3161               s += UTF8SKIP(s);
3162          }
3163          tmps = t;
3164     }
3165 #   ifdef FCRYPT
3166     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3167 #   else
3168     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3169 #   endif
3170     Safefree(t);
3171 #else
3172     DIE(aTHX_
3173       "The crypt() function is unimplemented due to excessive paranoia.");
3174 #endif
3175     SETs(TARG);
3176     RETURN;
3177 }
3178
3179 PP(pp_ucfirst)
3180 {
3181     dSP;
3182     SV *sv = TOPs;
3183     register U8 *s;
3184     STRLEN slen;
3185
3186     if (DO_UTF8(sv)) {
3187         U8 tmpbuf[UTF8_MAXLEN*2+1];
3188         STRLEN ulen;
3189         STRLEN tculen;
3190
3191         s = (U8*)SvPV(sv, slen);
3192         utf8_to_uvchr(s, &ulen);
3193
3194         toTITLE_utf8(s, tmpbuf, &tculen);
3195         utf8_to_uvchr(tmpbuf, 0);
3196
3197         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3198             dTARGET;
3199             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3200             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3201             SvUTF8_on(TARG);
3202             SETs(TARG);
3203         }
3204         else {
3205             s = (U8*)SvPV_force(sv, slen);
3206             Copy(tmpbuf, s, tculen, U8);
3207         }
3208     }
3209     else {
3210         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3211             dTARGET;
3212             SvUTF8_off(TARG);                           /* decontaminate */
3213             sv_setsv(TARG, sv);
3214             sv = TARG;
3215             SETs(sv);
3216         }
3217         s = (U8*)SvPV_force(sv, slen);
3218         if (*s) {
3219             if (IN_LOCALE_RUNTIME) {
3220                 TAINT;
3221                 SvTAINTED_on(sv);
3222                 *s = toUPPER_LC(*s);
3223             }
3224             else
3225                 *s = toUPPER(*s);
3226         }
3227     }
3228     if (SvSMAGICAL(sv))
3229         mg_set(sv);
3230     RETURN;
3231 }
3232
3233 PP(pp_lcfirst)
3234 {
3235     dSP;
3236     SV *sv = TOPs;
3237     register U8 *s;
3238     STRLEN slen;
3239
3240     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3241         STRLEN ulen;
3242         U8 tmpbuf[UTF8_MAXLEN*2+1];
3243         U8 *tend;
3244         UV uv;
3245
3246         toLOWER_utf8(s, tmpbuf, &ulen);
3247         uv = utf8_to_uvchr(tmpbuf, 0);
3248
3249         tend = uvchr_to_utf8(tmpbuf, uv);
3250
3251         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3252             dTARGET;
3253             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3254             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3255             SvUTF8_on(TARG);
3256             SETs(TARG);
3257         }
3258         else {
3259             s = (U8*)SvPV_force(sv, slen);
3260             Copy(tmpbuf, s, ulen, U8);
3261         }
3262     }
3263     else {
3264         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3265             dTARGET;
3266             SvUTF8_off(TARG);                           /* decontaminate */
3267             sv_setsv(TARG, sv);
3268             sv = TARG;
3269             SETs(sv);
3270         }
3271         s = (U8*)SvPV_force(sv, slen);
3272         if (*s) {
3273             if (IN_LOCALE_RUNTIME) {
3274                 TAINT;
3275                 SvTAINTED_on(sv);
3276                 *s = toLOWER_LC(*s);
3277             }
3278             else
3279                 *s = toLOWER(*s);
3280         }
3281     }
3282     if (SvSMAGICAL(sv))
3283         mg_set(sv);
3284     RETURN;
3285 }
3286
3287 PP(pp_uc)
3288 {
3289     dSP;
3290     SV *sv = TOPs;
3291     register U8 *s;
3292     STRLEN len;
3293
3294     if (DO_UTF8(sv)) {
3295         dTARGET;
3296         STRLEN ulen;
3297         register U8 *d;
3298         U8 *send;
3299         U8 tmpbuf[UTF8_MAXLEN*2+1];
3300
3301         s = (U8*)SvPV(sv,len);
3302         if (!len) {
3303             SvUTF8_off(TARG);                           /* decontaminate */
3304             sv_setpvn(TARG, "", 0);
3305             SETs(TARG);
3306         }
3307         else {
3308             (void)SvUPGRADE(TARG, SVt_PV);
3309             SvGROW(TARG, (len * 2) + 1);
3310             (void)SvPOK_only(TARG);
3311             d = (U8*)SvPVX(TARG);
3312             send = s + len;
3313             while (s < send) {
3314                 toUPPER_utf8(s, tmpbuf, &ulen);
3315                 Copy(tmpbuf, d, ulen, U8);
3316                 d += ulen;
3317                 s += UTF8SKIP(s);
3318             }
3319             *d = '\0';
3320             SvUTF8_on(TARG);
3321             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3322             SETs(TARG);
3323         }
3324     }
3325     else {
3326         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3327             dTARGET;
3328             SvUTF8_off(TARG);                           /* decontaminate */
3329             sv_setsv(TARG, sv);
3330             sv = TARG;
3331             SETs(sv);
3332         }
3333         s = (U8*)SvPV_force(sv, len);
3334         if (len) {
3335             register U8 *send = s + len;
3336
3337             if (IN_LOCALE_RUNTIME) {
3338                 TAINT;
3339                 SvTAINTED_on(sv);
3340                 for (; s < send; s++)
3341                     *s = toUPPER_LC(*s);
3342             }
3343             else {
3344                 for (; s < send; s++)
3345                     *s = toUPPER(*s);
3346             }
3347         }
3348     }
3349     if (SvSMAGICAL(sv))
3350         mg_set(sv);
3351     RETURN;
3352 }
3353
3354 PP(pp_lc)
3355 {
3356     dSP;
3357     SV *sv = TOPs;
3358     register U8 *s;
3359     STRLEN len;
3360
3361     if (DO_UTF8(sv)) {
3362         dTARGET;
3363         STRLEN ulen;
3364         register U8 *d;
3365         U8 *send;
3366         U8 tmpbuf[UTF8_MAXLEN*2+1];
3367
3368         s = (U8*)SvPV(sv,len);
3369         if (!len) {
3370             SvUTF8_off(TARG);                           /* decontaminate */
3371             sv_setpvn(TARG, "", 0);
3372             SETs(TARG);
3373         }
3374         else {
3375             (void)SvUPGRADE(TARG, SVt_PV);
3376             SvGROW(TARG, (len * 2) + 1);
3377             (void)SvPOK_only(TARG);
3378             d = (U8*)SvPVX(TARG);
3379             send = s + len;
3380             while (s < send) {
3381                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3382 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3383                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3384                      /*
3385                       * Now if the sigma is NOT followed by
3386                       * /$ignorable_sequence$cased_letter/;
3387                       * and it IS preceded by
3388                       * /$cased_letter$ignorable_sequence/;
3389                       * where $ignorable_sequence is
3390                       * [\x{2010}\x{AD}\p{Mn}]*
3391                       * and $cased_letter is
3392                       * [\p{Ll}\p{Lo}\p{Lt}]
3393                       * then it should be mapped to 0x03C2,
3394                       * (GREEK SMALL LETTER FINAL SIGMA),
3395                       * instead of staying 0x03A3.
3396                       * See lib/unicore/SpecCase.txt.
3397                       */
3398                 }
3399                 Copy(tmpbuf, d, ulen, U8);
3400                 d += ulen;
3401                 s += UTF8SKIP(s);
3402             }
3403             *d = '\0';
3404             SvUTF8_on(TARG);
3405             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3406             SETs(TARG);
3407         }
3408     }
3409     else {
3410         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3411             dTARGET;
3412             SvUTF8_off(TARG);                           /* decontaminate */
3413             sv_setsv(TARG, sv);
3414             sv = TARG;
3415             SETs(sv);
3416         }
3417
3418         s = (U8*)SvPV_force(sv, len);
3419         if (len) {
3420             register U8 *send = s + len;
3421
3422             if (IN_LOCALE_RUNTIME) {
3423                 TAINT;
3424                 SvTAINTED_on(sv);
3425                 for (; s < send; s++)
3426                     *s = toLOWER_LC(*s);
3427             }
3428             else {
3429                 for (; s < send; s++)
3430                     *s = toLOWER(*s);
3431             }
3432         }
3433     }
3434     if (SvSMAGICAL(sv))
3435         mg_set(sv);
3436     RETURN;
3437 }
3438
3439 PP(pp_quotemeta)
3440 {
3441     dSP; dTARGET;
3442     SV *sv = TOPs;
3443     STRLEN len;
3444     register char *s = SvPV(sv,len);
3445     register char *d;
3446
3447     SvUTF8_off(TARG);                           /* decontaminate */
3448     if (len) {
3449         (void)SvUPGRADE(TARG, SVt_PV);
3450         SvGROW(TARG, (len * 2) + 1);
3451         d = SvPVX(TARG);
3452         if (DO_UTF8(sv)) {
3453             while (len) {
3454                 if (UTF8_IS_CONTINUED(*s)) {
3455                     STRLEN ulen = UTF8SKIP(s);
3456                     if (ulen > len)
3457                         ulen = len;
3458                     len -= ulen;
3459                     while (ulen--)
3460                         *d++ = *s++;
3461                 }
3462                 else {
3463                     if (!isALNUM(*s))
3464                         *d++ = '\\';
3465                     *d++ = *s++;
3466                     len--;
3467                 }
3468             }
3469             SvUTF8_on(TARG);
3470         }
3471         else {
3472             while (len--) {
3473                 if (!isALNUM(*s))
3474                     *d++ = '\\';
3475                 *d++ = *s++;
3476             }
3477         }
3478         *d = '\0';
3479         SvCUR_set(TARG, d - SvPVX(TARG));
3480         (void)SvPOK_only_UTF8(TARG);
3481     }
3482     else
3483         sv_setpvn(TARG, s, len);
3484     SETs(TARG);
3485     if (SvSMAGICAL(TARG))
3486         mg_set(TARG);
3487     RETURN;
3488 }
3489
3490 /* Arrays. */
3491
3492 PP(pp_aslice)
3493 {
3494     dSP; dMARK; dORIGMARK;
3495     register SV** svp;
3496     register AV* av = (AV*)POPs;
3497     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3498     I32 arybase = PL_curcop->cop_arybase;
3499     I32 elem;
3500
3501     if (SvTYPE(av) == SVt_PVAV) {
3502         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3503             I32 max = -1;
3504             for (svp = MARK + 1; svp <= SP; svp++) {
3505                 elem = SvIVx(*svp);
3506                 if (elem > max)
3507                     max = elem;
3508             }
3509             if (max > AvMAX(av))
3510                 av_extend(av, max);
3511         }
3512         while (++MARK <= SP) {
3513             elem = SvIVx(*MARK);
3514
3515             if (elem > 0)
3516                 elem -= arybase;
3517             svp = av_fetch(av, elem, lval);
3518             if (lval) {
3519                 if (!svp || *svp == &PL_sv_undef)
3520                     DIE(aTHX_ PL_no_aelem, elem);
3521                 if (PL_op->op_private & OPpLVAL_INTRO)
3522                     save_aelem(av, elem, svp);
3523             }
3524             *MARK = svp ? *svp : &PL_sv_undef;
3525         }
3526     }
3527     if (GIMME != G_ARRAY) {
3528         MARK = ORIGMARK;
3529         *++MARK = *SP;
3530         SP = MARK;
3531     }
3532     RETURN;
3533 }
3534
3535 /* Associative arrays. */
3536
3537 PP(pp_each)
3538 {
3539     dSP;
3540     HV *hash = (HV*)POPs;
3541     HE *entry;
3542     I32 gimme = GIMME_V;
3543     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3544
3545     PUTBACK;
3546     /* might clobber stack_sp */
3547     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3548     SPAGAIN;
3549
3550     EXTEND(SP, 2);
3551     if (entry) {
3552         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
3553         if (gimme == G_ARRAY) {
3554             SV *val;
3555             PUTBACK;
3556             /* might clobber stack_sp */
3557             val = realhv ?
3558                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3559             SPAGAIN;
3560             PUSHs(val);
3561         }
3562     }
3563     else if (gimme == G_SCALAR)
3564         RETPUSHUNDEF;
3565
3566     RETURN;
3567 }
3568
3569 PP(pp_values)
3570 {
3571     return do_kv();
3572 }
3573
3574 PP(pp_keys)
3575 {
3576     return do_kv();
3577 }
3578
3579 PP(pp_delete)
3580 {
3581     dSP;
3582     I32 gimme = GIMME_V;
3583     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3584     SV *sv;
3585     HV *hv;
3586
3587     if (PL_op->op_private & OPpSLICE) {
3588         dMARK; dORIGMARK;
3589         U32 hvtype;
3590         hv = (HV*)POPs;
3591         hvtype = SvTYPE(hv);
3592         if (hvtype == SVt_PVHV) {                       /* hash element */
3593             while (++MARK <= SP) {
3594                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3595                 *MARK = sv ? sv : &PL_sv_undef;
3596             }
3597         }
3598         else if (hvtype == SVt_PVAV) {
3599             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
3600                 while (++MARK <= SP) {
3601                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3602                     *MARK = sv ? sv : &PL_sv_undef;
3603                 }
3604             }
3605             else {                                      /* pseudo-hash element */
3606                 while (++MARK <= SP) {
3607                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3608                     *MARK = sv ? sv : &PL_sv_undef;
3609                 }
3610             }
3611         }
3612         else
3613             DIE(aTHX_ "Not a HASH reference");
3614         if (discard)
3615             SP = ORIGMARK;
3616         else if (gimme == G_SCALAR) {
3617             MARK = ORIGMARK;
3618             *++MARK = *SP;
3619             SP = MARK;
3620         }
3621     }
3622     else {
3623         SV *keysv = POPs;
3624         hv = (HV*)POPs;
3625         if (SvTYPE(hv) == SVt_PVHV)
3626             sv = hv_delete_ent(hv, keysv, discard, 0);
3627         else if (SvTYPE(hv) == SVt_PVAV) {
3628             if (PL_op->op_flags & OPf_SPECIAL)
3629                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3630             else
3631                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3632         }
3633         else
3634             DIE(aTHX_ "Not a HASH reference");
3635         if (!sv)
3636             sv = &PL_sv_undef;
3637         if (!discard)
3638             PUSHs(sv);
3639     }
3640     RETURN;
3641 }
3642
3643 PP(pp_exists)
3644 {
3645     dSP;
3646     SV *tmpsv;
3647     HV *hv;
3648
3649     if (PL_op->op_private & OPpEXISTS_SUB) {
3650         GV *gv;
3651         CV *cv;
3652         SV *sv = POPs;
3653         cv = sv_2cv(sv, &hv, &gv, FALSE);
3654         if (cv)
3655             RETPUSHYES;
3656         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3657             RETPUSHYES;
3658         RETPUSHNO;
3659     }
3660     tmpsv = POPs;
3661     hv = (HV*)POPs;
3662     if (SvTYPE(hv) == SVt_PVHV) {
3663         if (hv_exists_ent(hv, tmpsv, 0))
3664             RETPUSHYES;
3665     }
3666     else if (SvTYPE(hv) == SVt_PVAV) {
3667         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3668             if (av_exists((AV*)hv, SvIV(tmpsv)))
3669                 RETPUSHYES;
3670         }
3671         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
3672             RETPUSHYES;
3673     }
3674     else {
3675         DIE(aTHX_ "Not a HASH reference");
3676     }
3677     RETPUSHNO;
3678 }
3679
3680 PP(pp_hslice)
3681 {
3682     dSP; dMARK; dORIGMARK;
3683     register HV *hv = (HV*)POPs;
3684     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3685     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3686
3687     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3688         DIE(aTHX_ "Can't localize pseudo-hash element");
3689
3690     if (realhv || SvTYPE(hv) == SVt_PVAV) {
3691         while (++MARK <= SP) {
3692             SV *keysv = *MARK;
3693             SV **svp;
3694             I32 preeminent = SvRMAGICAL(hv) ? 1 :
3695                                 realhv ? hv_exists_ent(hv, keysv, 0)
3696                                        : avhv_exists_ent((AV*)hv, keysv, 0);
3697             if (realhv) {
3698                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3699                 svp = he ? &HeVAL(he) : 0;
3700             }
3701             else {
3702                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3703             }
3704             if (lval) {
3705                 if (!svp || *svp == &PL_sv_undef) {
3706                     STRLEN n_a;
3707                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3708                 }
3709                 if (PL_op->op_private & OPpLVAL_INTRO) {
3710                     if (preeminent)
3711                         save_helem(hv, keysv, svp);
3712                     else {
3713                         STRLEN keylen;
3714                         char *key = SvPV(keysv, keylen);
3715                         SAVEDELETE(hv, savepvn(key,keylen), keylen);
3716                     }
3717                 }
3718             }
3719             *MARK = svp ? *svp : &PL_sv_undef;
3720         }
3721     }
3722     if (GIMME != G_ARRAY) {
3723         MARK = ORIGMARK;
3724         *++MARK = *SP;
3725         SP = MARK;
3726     }
3727     RETURN;
3728 }
3729
3730 /* List operators. */
3731
3732 PP(pp_list)
3733 {
3734     dSP; dMARK;
3735     if (GIMME != G_ARRAY) {
3736         if (++MARK <= SP)
3737             *MARK = *SP;                /* unwanted list, return last item */
3738         else
3739             *MARK = &PL_sv_undef;
3740         SP = MARK;
3741     }
3742     RETURN;
3743 }
3744
3745 PP(pp_lslice)
3746 {
3747     dSP;
3748     SV **lastrelem = PL_stack_sp;
3749     SV **lastlelem = PL_stack_base + POPMARK;
3750     SV **firstlelem = PL_stack_base + POPMARK + 1;
3751     register SV **firstrelem = lastlelem + 1;
3752     I32 arybase = PL_curcop->cop_arybase;
3753     I32 lval = PL_op->op_flags & OPf_MOD;
3754     I32 is_something_there = lval;
3755
3756     register I32 max = lastrelem - lastlelem;
3757     register SV **lelem;
3758     register I32 ix;
3759
3760     if (GIMME != G_ARRAY) {
3761         ix = SvIVx(*lastlelem);
3762         if (ix < 0)
3763             ix += max;
3764         else
3765             ix -= arybase;
3766         if (ix < 0 || ix >= max)
3767             *firstlelem = &PL_sv_undef;
3768         else
3769             *firstlelem = firstrelem[ix];
3770         SP = firstlelem;
3771         RETURN;
3772     }
3773
3774     if (max == 0) {
3775         SP = firstlelem - 1;
3776         RETURN;
3777     }
3778
3779     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3780         ix = SvIVx(*lelem);
3781         if (ix < 0)
3782             ix += max;
3783         else
3784             ix -= arybase;
3785         if (ix < 0 || ix >= max)
3786             *lelem = &PL_sv_undef;
3787         else {
3788             is_something_there = TRUE;
3789             if (!(*lelem = firstrelem[ix]))
3790                 *lelem = &PL_sv_undef;
3791         }
3792     }
3793     if (is_something_there)
3794         SP = lastlelem;
3795     else
3796         SP = firstlelem - 1;
3797     RETURN;
3798 }
3799
3800 PP(pp_anonlist)
3801 {
3802     dSP; dMARK; dORIGMARK;
3803     I32 items = SP - MARK;
3804     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3805     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3806     XPUSHs(av);
3807     RETURN;
3808 }
3809
3810 PP(pp_anonhash)
3811 {
3812     dSP; dMARK; dORIGMARK;
3813     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3814
3815     while (MARK < SP) {
3816         SV* key = *++MARK;
3817         SV *val = NEWSV(46, 0);
3818         if (MARK < SP)
3819             sv_setsv(val, *++MARK);
3820         else if (ckWARN(WARN_MISC))
3821             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3822         (void)hv_store_ent(hv,key,val,0);
3823     }
3824     SP = ORIGMARK;
3825     XPUSHs((SV*)hv);
3826     RETURN;
3827 }
3828
3829 PP(pp_splice)
3830 {
3831     dSP; dMARK; dORIGMARK;
3832     register AV *ary = (AV*)*++MARK;
3833     register SV **src;
3834     register SV **dst;
3835     register I32 i;
3836     register I32 offset;
3837     register I32 length;
3838     I32 newlen;
3839     I32 after;
3840     I32 diff;
3841     SV **tmparyval = 0;
3842     MAGIC *mg;
3843
3844     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3845         *MARK-- = SvTIED_obj((SV*)ary, mg);
3846         PUSHMARK(MARK);
3847         PUTBACK;
3848         ENTER;
3849         call_method("SPLICE",GIMME_V);
3850         LEAVE;
3851         SPAGAIN;
3852         RETURN;
3853     }
3854
3855     SP++;
3856
3857     if (++MARK < SP) {
3858         offset = i = SvIVx(*MARK);
3859         if (offset < 0)
3860             offset += AvFILLp(ary) + 1;
3861         else
3862             offset -= PL_curcop->cop_arybase;
3863         if (offset < 0)
3864             DIE(aTHX_ PL_no_aelem, i);
3865         if (++MARK < SP) {
3866             length = SvIVx(*MARK++);
3867             if (length < 0) {
3868                 length += AvFILLp(ary) - offset + 1;
3869                 if (length < 0)
3870                     length = 0;
3871             }
3872         }
3873         else
3874             length = AvMAX(ary) + 1;            /* close enough to infinity */
3875     }
3876     else {
3877         offset = 0;
3878         length = AvMAX(ary) + 1;
3879     }
3880     if (offset > AvFILLp(ary) + 1)
3881         offset = AvFILLp(ary) + 1;
3882     after = AvFILLp(ary) + 1 - (offset + length);
3883     if (after < 0) {                            /* not that much array */
3884         length += after;                        /* offset+length now in array */
3885         after = 0;
3886         if (!AvALLOC(ary))
3887             av_extend(ary, 0);
3888     }
3889
3890     /* At this point, MARK .. SP-1 is our new LIST */
3891
3892     newlen = SP - MARK;
3893     diff = newlen - length;
3894     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3895         av_reify(ary);
3896
3897     if (diff < 0) {                             /* shrinking the area */
3898         if (newlen) {
3899             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3900             Copy(MARK, tmparyval, newlen, SV*);
3901         }
3902
3903         MARK = ORIGMARK + 1;
3904         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3905             MEXTEND(MARK, length);
3906             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3907             if (AvREAL(ary)) {
3908                 EXTEND_MORTAL(length);
3909                 for (i = length, dst = MARK; i; i--) {
3910                     sv_2mortal(*dst);   /* free them eventualy */
3911                     dst++;
3912                 }
3913             }
3914             MARK += length - 1;
3915         }
3916         else {
3917             *MARK = AvARRAY(ary)[offset+length-1];
3918             if (AvREAL(ary)) {
3919                 sv_2mortal(*MARK);
3920                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3921                     SvREFCNT_dec(*dst++);       /* free them now */
3922             }
3923         }
3924         AvFILLp(ary) += diff;
3925
3926         /* pull up or down? */
3927
3928         if (offset < after) {                   /* easier to pull up */
3929             if (offset) {                       /* esp. if nothing to pull */
3930                 src = &AvARRAY(ary)[offset-1];
3931                 dst = src - diff;               /* diff is negative */
3932                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3933                     *dst-- = *src--;
3934             }
3935             dst = AvARRAY(ary);
3936             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3937             AvMAX(ary) += diff;
3938         }
3939         else {
3940             if (after) {                        /* anything to pull down? */
3941                 src = AvARRAY(ary) + offset + length;
3942                 dst = src + diff;               /* diff is negative */
3943                 Move(src, dst, after, SV*);
3944             }
3945             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3946                                                 /* avoid later double free */
3947         }
3948         i = -diff;
3949         while (i)
3950             dst[--i] = &PL_sv_undef;
3951
3952         if (newlen) {
3953             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3954               newlen; newlen--) {
3955                 *dst = NEWSV(46, 0);
3956                 sv_setsv(*dst++, *src++);
3957             }
3958             Safefree(tmparyval);
3959         }
3960     }
3961     else {                                      /* no, expanding (or same) */
3962         if (length) {
3963             New(452, tmparyval, length, SV*);   /* so remember deletion */
3964             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3965         }
3966
3967         if (diff > 0) {                         /* expanding */
3968
3969             /* push up or down? */
3970
3971             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3972                 if (offset) {
3973                     src = AvARRAY(ary);
3974                     dst = src - diff;
3975                     Move(src, dst, offset, SV*);
3976                 }
3977                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3978                 AvMAX(ary) += diff;
3979                 AvFILLp(ary) += diff;
3980             }
3981             else {
3982                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3983                     av_extend(ary, AvFILLp(ary) + diff);
3984                 AvFILLp(ary) += diff;
3985
3986                 if (after) {
3987                     dst = AvARRAY(ary) + AvFILLp(ary);
3988                     src = dst - diff;
3989                     for (i = after; i; i--) {
3990                         *dst-- = *src--;
3991                     }
3992                 }
3993             }
3994         }
3995
3996         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3997             *dst = NEWSV(46, 0);
3998             sv_setsv(*dst++, *src++);
3999         }
4000         MARK = ORIGMARK + 1;
4001         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4002             if (length) {
4003                 Copy(tmparyval, MARK, length, SV*);
4004                 if (AvREAL(ary)) {
4005                     EXTEND_MORTAL(length);
4006                     for (i = length, dst = MARK; i; i--) {
4007                         sv_2mortal(*dst);       /* free them eventualy */
4008                         dst++;
4009                     }
4010                 }
4011                 Safefree(tmparyval);
4012             }
4013             MARK += length - 1;
4014         }
4015         else if (length--) {
4016             *MARK = tmparyval[length];
4017             if (AvREAL(ary)) {
4018                 sv_2mortal(*MARK);
4019                 while (length-- > 0)
4020                     SvREFCNT_dec(tmparyval[length]);
4021             }
4022             Safefree(tmparyval);
4023         }
4024         else
4025             *MARK = &PL_sv_undef;
4026     }
4027     SP = MARK;
4028     RETURN;
4029 }
4030
4031 PP(pp_push)
4032 {
4033     dSP; dMARK; dORIGMARK; dTARGET;
4034     register AV *ary = (AV*)*++MARK;
4035     register SV *sv = &PL_sv_undef;
4036     MAGIC *mg;
4037
4038     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4039         *MARK-- = SvTIED_obj((SV*)ary, mg);
4040         PUSHMARK(MARK);
4041         PUTBACK;
4042         ENTER;
4043         call_method("PUSH",G_SCALAR|G_DISCARD);
4044         LEAVE;
4045         SPAGAIN;
4046     }
4047     else {
4048         /* Why no pre-extend of ary here ? */
4049         for (++MARK; MARK <= SP; MARK++) {
4050             sv = NEWSV(51, 0);
4051             if (*MARK)
4052                 sv_setsv(sv, *MARK);
4053             av_push(ary, sv);
4054         }
4055     }
4056     SP = ORIGMARK;
4057     PUSHi( AvFILL(ary) + 1 );
4058     RETURN;
4059 }
4060
4061 PP(pp_pop)
4062 {
4063     dSP;
4064     AV *av = (AV*)POPs;
4065     SV *sv = av_pop(av);
4066     if (AvREAL(av))
4067         (void)sv_2mortal(sv);
4068     PUSHs(sv);
4069     RETURN;
4070 }
4071
4072 PP(pp_shift)
4073 {
4074     dSP;
4075     AV *av = (AV*)POPs;
4076     SV *sv = av_shift(av);
4077     EXTEND(SP, 1);
4078     if (!sv)
4079         RETPUSHUNDEF;
4080     if (AvREAL(av))
4081         (void)sv_2mortal(sv);
4082     PUSHs(sv);
4083     RETURN;
4084 }
4085
4086 PP(pp_unshift)
4087 {
4088     dSP; dMARK; dORIGMARK; dTARGET;
4089     register AV *ary = (AV*)*++MARK;
4090     register SV *sv;
4091     register I32 i = 0;
4092     MAGIC *mg;
4093
4094     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4095         *MARK-- = SvTIED_obj((SV*)ary, mg);
4096         PUSHMARK(MARK);
4097         PUTBACK;
4098         ENTER;
4099         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4100         LEAVE;
4101         SPAGAIN;
4102     }
4103     else {
4104         av_unshift(ary, SP - MARK);
4105         while (MARK < SP) {
4106             sv = NEWSV(27, 0);
4107             sv_setsv(sv, *++MARK);
4108             (void)av_store(ary, i++, sv);
4109         }
4110     }
4111     SP = ORIGMARK;
4112     PUSHi( AvFILL(ary) + 1 );
4113     RETURN;
4114 }
4115
4116 PP(pp_reverse)
4117 {
4118     dSP; dMARK;
4119     register SV *tmp;
4120     SV **oldsp = SP;
4121
4122     if (GIMME == G_ARRAY) {
4123         MARK++;
4124         while (MARK < SP) {
4125             tmp = *MARK;
4126             *MARK++ = *SP;
4127             *SP-- = tmp;
4128         }
4129         /* safe as long as stack cannot get extended in the above */
4130         SP = oldsp;
4131     }
4132     else {
4133         register char *up;
4134         register char *down;
4135         register I32 tmp;
4136         dTARGET;
4137         STRLEN len;
4138
4139         SvUTF8_off(TARG);                               /* decontaminate */
4140         if (SP - MARK > 1)
4141             do_join(TARG, &PL_sv_no, MARK, SP);
4142         else
4143             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4144         up = SvPV_force(TARG, len);
4145         if (len > 1) {
4146             if (DO_UTF8(TARG)) {        /* first reverse each character */
4147                 U8* s = (U8*)SvPVX(TARG);
4148                 U8* send = (U8*)(s + len);
4149                 while (s < send) {
4150                     if (UTF8_IS_INVARIANT(*s)) {
4151                         s++;
4152                         continue;
4153                     }
4154                     else {
4155                         if (!utf8_to_uvchr(s, 0))
4156                             break;
4157                         up = (char*)s;
4158                         s += UTF8SKIP(s);
4159                         down = (char*)(s - 1);
4160                         /* reverse this character */
4161                         while (down > up) {
4162                             tmp = *up;
4163                             *up++ = *down;
4164                             *down-- = tmp;
4165                         }
4166                     }
4167                 }
4168                 up = SvPVX(TARG);
4169             }
4170             down = SvPVX(TARG) + len - 1;
4171             while (down > up) {
4172                 tmp = *up;
4173                 *up++ = *down;
4174                 *down-- = tmp;
4175             }
4176             (void)SvPOK_only_UTF8(TARG);
4177         }
4178         SP = MARK + 1;
4179         SETTARG;
4180     }
4181     RETURN;
4182 }
4183
4184 PP(pp_split)
4185 {
4186     dSP; dTARG;
4187     AV *ary;
4188     register IV limit = POPi;                   /* note, negative is forever */
4189     SV *sv = POPs;
4190     STRLEN len;
4191     register char *s = SvPV(sv, len);
4192     bool do_utf8 = DO_UTF8(sv);
4193     char *strend = s + len;
4194     register PMOP *pm;
4195     register REGEXP *rx;
4196     register SV *dstr;
4197     register char *m;
4198     I32 iters = 0;
4199     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4200     I32 maxiters = slen + 10;
4201     I32 i;
4202     char *orig;
4203     I32 origlimit = limit;
4204     I32 realarray = 0;
4205     I32 base;
4206     AV *oldstack = PL_curstack;
4207     I32 gimme = GIMME_V;
4208     I32 oldsave = PL_savestack_ix;
4209     I32 make_mortal = 1;
4210     MAGIC *mg = (MAGIC *) NULL;
4211
4212 #ifdef DEBUGGING
4213     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4214 #else
4215     pm = (PMOP*)POPs;
4216 #endif
4217     if (!pm || !s)
4218         DIE(aTHX_ "panic: pp_split");
4219     rx = PM_GETRE(pm);
4220
4221     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4222              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4223
4224     PL_reg_match_utf8 = do_utf8;
4225
4226     if (pm->op_pmreplroot) {
4227 #ifdef USE_ITHREADS
4228         ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4229 #else
4230         ary = GvAVn((GV*)pm->op_pmreplroot);
4231 #endif
4232     }
4233     else if (gimme != G_ARRAY)
4234 #ifdef USE_5005THREADS
4235         ary = (AV*)PL_curpad[0];
4236 #else
4237         ary = GvAVn(PL_defgv);
4238 #endif /* USE_5005THREADS */
4239     else
4240         ary = Nullav;
4241     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4242         realarray = 1;
4243         PUTBACK;
4244         av_extend(ary,0);
4245         av_clear(ary);
4246         SPAGAIN;
4247         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4248             PUSHMARK(SP);
4249             XPUSHs(SvTIED_obj((SV*)ary, mg));
4250         }
4251         else {
4252             if (!AvREAL(ary)) {
4253                 AvREAL_on(ary);
4254                 AvREIFY_off(ary);
4255                 for (i = AvFILLp(ary); i >= 0; i--)
4256                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4257             }
4258             /* temporarily switch stacks */
4259             SWITCHSTACK(PL_curstack, ary);
4260             make_mortal = 0;
4261         }
4262     }
4263     base = SP - PL_stack_base;
4264     orig = s;
4265     if (pm->op_pmflags & PMf_SKIPWHITE) {
4266         if (pm->op_pmflags & PMf_LOCALE) {
4267             while (isSPACE_LC(*s))
4268                 s++;
4269         }
4270         else {
4271             while (isSPACE(*s))
4272                 s++;
4273         }
4274     }
4275     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4276         SAVEINT(PL_multiline);
4277         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4278     }
4279
4280     if (!limit)
4281         limit = maxiters + 2;
4282     if (pm->op_pmflags & PMf_WHITE) {
4283         while (--limit) {
4284             m = s;
4285             while (m < strend &&
4286                    !((pm->op_pmflags & PMf_LOCALE)
4287                      ? isSPACE_LC(*m) : isSPACE(*m)))
4288                 ++m;
4289             if (m >= strend)
4290                 break;
4291
4292             dstr = NEWSV(30, m-s);
4293             sv_setpvn(dstr, s, m-s);
4294             if (make_mortal)
4295                 sv_2mortal(dstr);
4296             if (do_utf8)
4297                 (void)SvUTF8_on(dstr);
4298             XPUSHs(dstr);
4299
4300             s = m + 1;
4301             while (s < strend &&
4302                    ((pm->op_pmflags & PMf_LOCALE)
4303                     ? isSPACE_LC(*s) : isSPACE(*s)))
4304                 ++s;
4305         }
4306     }
4307     else if (strEQ("^", rx->precomp)) {
4308         while (--limit) {
4309             /*SUPPRESS 530*/
4310             for (m = s; m < strend && *m != '\n'; m++) ;
4311             m++;
4312             if (m >= strend)
4313                 break;
4314             dstr = NEWSV(30, m-s);
4315             sv_setpvn(dstr, s, m-s);
4316             if (make_mortal)
4317                 sv_2mortal(dstr);
4318             if (do_utf8)
4319                 (void)SvUTF8_on(dstr);
4320             XPUSHs(dstr);
4321             s = m;
4322         }
4323     }
4324     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4325              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4326              && (rx->reganch & ROPT_CHECK_ALL)
4327              && !(rx->reganch & ROPT_ANCH)) {
4328         int tail = (rx->reganch & RE_INTUIT_TAIL);
4329         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4330
4331         len = rx->minlen;
4332         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4333             STRLEN n_a;
4334             char c = *SvPV(csv, n_a);
4335             while (--limit) {
4336                 /*SUPPRESS 530*/
4337                 for (m = s; m < strend && *m != c; 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                 /* The rx->minlen is in characters but we want to step
4348                  * s ahead by bytes. */
4349                 if (do_utf8)
4350                     s = (char*)utf8_hop((U8*)m, len);
4351                 else
4352                     s = m + len; /* Fake \n at the end */
4353             }
4354         }
4355         else {
4356 #ifndef lint
4357             while (s < strend && --limit &&
4358               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4359                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4360 #endif
4361             {
4362                 dstr = NEWSV(31, m-s);
4363                 sv_setpvn(dstr, s, m-s);
4364                 if (make_mortal)
4365                     sv_2mortal(dstr);
4366                 if (do_utf8)
4367                     (void)SvUTF8_on(dstr);
4368                 XPUSHs(dstr);
4369                 /* The rx->minlen is in characters but we want to step
4370                  * s ahead by bytes. */
4371                 if (do_utf8)
4372                     s = (char*)utf8_hop((U8*)m, len);
4373                 else
4374                     s = m + len; /* Fake \n at the end */
4375             }
4376         }
4377     }
4378     else {
4379         maxiters += slen * rx->nparens;
4380         while (s < strend && --limit
4381 /*             && (!rx->check_substr
4382                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4383                                                  0, NULL))))
4384 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4385                               1 /* minend */, sv, NULL, 0))
4386         {
4387             TAINT_IF(RX_MATCH_TAINTED(rx));
4388             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4389                 m = s;
4390                 s = orig;
4391                 orig = rx->subbeg;
4392                 s = orig + (m - s);
4393                 strend = s + (strend - m);
4394             }
4395             m = rx->startp[0] + orig;
4396             dstr = NEWSV(32, m-s);
4397             sv_setpvn(dstr, s, m-s);
4398             if (make_mortal)
4399                 sv_2mortal(dstr);
4400             if (do_utf8)
4401                 (void)SvUTF8_on(dstr);
4402             XPUSHs(dstr);
4403             if (rx->nparens) {
4404                 for (i = 1; i <= rx->nparens; i++) {
4405                     s = rx->startp[i] + orig;
4406                     m = rx->endp[i] + orig;
4407
4408                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4409                        parens that didn't match -- they should be set to
4410                        undef, not the empty string */
4411                     if (m >= orig && s >= orig) {
4412                         dstr = NEWSV(33, m-s);
4413                         sv_setpvn(dstr, s, m-s);
4414                     }
4415                     else
4416                         dstr = &PL_sv_undef;  /* undef, not "" */
4417                     if (make_mortal)
4418                         sv_2mortal(dstr);
4419                     if (do_utf8)
4420                         (void)SvUTF8_on(dstr);
4421                     XPUSHs(dstr);
4422                 }
4423             }
4424             s = rx->endp[0] + orig;
4425         }
4426     }
4427
4428     LEAVE_SCOPE(oldsave);
4429     iters = (SP - PL_stack_base) - base;
4430     if (iters > maxiters)
4431         DIE(aTHX_ "Split loop");
4432
4433     /* keep field after final delim? */
4434     if (s < strend || (iters && origlimit)) {
4435         STRLEN l = strend - s;
4436         dstr = NEWSV(34, l);
4437         sv_setpvn(dstr, s, l);
4438         if (make_mortal)
4439             sv_2mortal(dstr);
4440         if (do_utf8)
4441             (void)SvUTF8_on(dstr);
4442         XPUSHs(dstr);
4443         iters++;
4444     }
4445     else if (!origlimit) {
4446         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4447             iters--, SP--;
4448     }
4449
4450     if (realarray) {
4451         if (!mg) {
4452             SWITCHSTACK(ary, oldstack);
4453             if (SvSMAGICAL(ary)) {
4454                 PUTBACK;
4455                 mg_set((SV*)ary);
4456                 SPAGAIN;
4457             }
4458             if (gimme == G_ARRAY) {
4459                 EXTEND(SP, iters);
4460                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4461                 SP += iters;
4462                 RETURN;
4463             }
4464         }
4465         else {
4466             PUTBACK;
4467             ENTER;
4468             call_method("PUSH",G_SCALAR|G_DISCARD);
4469             LEAVE;
4470             SPAGAIN;
4471             if (gimme == G_ARRAY) {
4472                 /* EXTEND should not be needed - we just popped them */
4473                 EXTEND(SP, iters);
4474                 for (i=0; i < iters; i++) {
4475                     SV **svp = av_fetch(ary, i, FALSE);
4476                     PUSHs((svp) ? *svp : &PL_sv_undef);
4477                 }
4478                 RETURN;
4479             }
4480         }
4481     }
4482     else {
4483         if (gimme == G_ARRAY)
4484             RETURN;
4485     }
4486     if (iters || !pm->op_pmreplroot) {
4487         GETTARGET;
4488         PUSHi(iters);
4489         RETURN;
4490     }
4491     RETPUSHUNDEF;
4492 }
4493
4494 #ifdef USE_5005THREADS
4495 void
4496 Perl_unlock_condpair(pTHX_ void *svv)
4497 {
4498     MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4499
4500     if (!mg)
4501         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4502     MUTEX_LOCK(MgMUTEXP(mg));
4503     if (MgOWNER(mg) != thr)
4504         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4505     MgOWNER(mg) = 0;
4506     COND_SIGNAL(MgOWNERCONDP(mg));
4507     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4508                           PTR2UV(thr), PTR2UV(svv)));
4509     MUTEX_UNLOCK(MgMUTEXP(mg));
4510 }
4511 #endif /* USE_5005THREADS */
4512
4513 PP(pp_lock)
4514 {
4515     dSP;
4516     dTOPss;
4517     SV *retsv = sv;
4518 #ifdef USE_5005THREADS
4519     sv_lock(sv);
4520 #endif /* USE_5005THREADS */
4521 #ifdef USE_ITHREADS
4522     shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4523     if(ssv)
4524         Perl_sharedsv_lock(aTHX_ ssv);
4525 #endif /* USE_ITHREADS */
4526     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4527         || SvTYPE(retsv) == SVt_PVCV) {
4528         retsv = refto(retsv);
4529     }
4530     SETs(retsv);
4531     RETURN;
4532 }
4533
4534 PP(pp_threadsv)
4535 {
4536 #ifdef USE_5005THREADS
4537     dSP;
4538     EXTEND(SP, 1);
4539     if (PL_op->op_private & OPpLVAL_INTRO)
4540         PUSHs(*save_threadsv(PL_op->op_targ));
4541     else
4542         PUSHs(THREADSV(PL_op->op_targ));
4543     RETURN;
4544 #else
4545     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4546 #endif /* USE_5005THREADS */
4547 }