pp.c

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