pp.c

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