pp.c

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