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
3037     XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3038     RETURN;
3039 }
3040
3041 PP(pp_chr)
3042 {
3043     dSP; dTARGET;
3044     char *tmps;
3045     UV value = POPu;
3046
3047     (void)SvUPGRADE(TARG,SVt_PV);
3048
3049     if (value > 255 && !IN_BYTES) {
3050         SvGROW(TARG, UNISKIP(value)+1);
3051         tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3052         SvCUR_set(TARG, tmps - SvPVX(TARG));
3053         *tmps = '\0';
3054         (void)SvPOK_only(TARG);
3055         SvUTF8_on(TARG);
3056         XPUSHs(TARG);
3057         RETURN;
3058     }
3059
3060     SvGROW(TARG,2);
3061     SvCUR_set(TARG, 1);
3062     tmps = SvPVX(TARG);
3063     *tmps++ = value;
3064     *tmps = '\0';
3065     (void)SvPOK_only(TARG);
3066     XPUSHs(TARG);
3067     RETURN;
3068 }
3069
3070 PP(pp_crypt)
3071 {
3072     dSP; dTARGET; dPOPTOPssrl;
3073     STRLEN n_a;
3074 #ifdef HAS_CRYPT
3075     STRLEN len;
3076     char *tmps = SvPV(left, len);
3077     char *t    = 0;
3078     if (DO_UTF8(left)) {
3079          /* If Unicode take the crypt() of the low 8 bits
3080           * of the characters of the string. */
3081          char *s    = tmps;
3082          char *send = tmps + len;
3083          STRLEN i   = 0;
3084          Newz(688, t, len, char);
3085          while (s < send) {
3086               t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3087               s += UTF8SKIP(s);
3088          }
3089          tmps = t;
3090     }
3091 #ifdef FCRYPT
3092     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3093 #else
3094     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3095 #endif
3096     Safefree(t);
3097 #else
3098     DIE(aTHX_
3099       "The crypt() function is unimplemented due to excessive paranoia.");
3100 #endif
3101     SETs(TARG);
3102     RETURN;
3103 }
3104
3105 PP(pp_ucfirst)
3106 {
3107     dSP;
3108     SV *sv = TOPs;
3109     register U8 *s;
3110     STRLEN slen;
3111
3112     if (DO_UTF8(sv)) {
3113         U8 tmpbuf[UTF8_MAXLEN*2+1];
3114         STRLEN ulen;
3115         STRLEN tculen;
3116
3117         s = (U8*)SvPV(sv, slen);
3118         utf8_to_uvchr(s, &ulen);
3119
3120         toTITLE_utf8(s, tmpbuf, &tculen);
3121         utf8_to_uvchr(tmpbuf, 0);
3122
3123         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3124             dTARGET;
3125             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3126             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3127             SvUTF8_on(TARG);
3128             SETs(TARG);
3129         }
3130         else {
3131             s = (U8*)SvPV_force(sv, slen);
3132             Copy(tmpbuf, s, tculen, U8);
3133         }
3134     }
3135     else {
3136         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3137             dTARGET;
3138             SvUTF8_off(TARG);                           /* decontaminate */
3139             sv_setsv(TARG, sv);
3140             sv = TARG;
3141             SETs(sv);
3142         }
3143         s = (U8*)SvPV_force(sv, slen);
3144         if (*s) {
3145             if (IN_LOCALE_RUNTIME) {
3146                 TAINT;
3147                 SvTAINTED_on(sv);
3148                 *s = toUPPER_LC(*s);
3149             }
3150             else
3151                 *s = toUPPER(*s);
3152         }
3153     }
3154     if (SvSMAGICAL(sv))
3155         mg_set(sv);
3156     RETURN;
3157 }
3158
3159 PP(pp_lcfirst)
3160 {
3161     dSP;
3162     SV *sv = TOPs;
3163     register U8 *s;
3164     STRLEN slen;
3165
3166     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3167         STRLEN ulen;
3168         U8 tmpbuf[UTF8_MAXLEN*2+1];
3169         U8 *tend;
3170         UV uv;
3171
3172         toLOWER_utf8(s, tmpbuf, &ulen);
3173         uv = utf8_to_uvchr(tmpbuf, 0);
3174
3175         tend = uvchr_to_utf8(tmpbuf, uv);
3176
3177         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3178             dTARGET;
3179             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3180             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3181             SvUTF8_on(TARG);
3182             SETs(TARG);
3183         }
3184         else {
3185             s = (U8*)SvPV_force(sv, slen);
3186             Copy(tmpbuf, s, ulen, U8);
3187         }
3188     }
3189     else {
3190         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3191             dTARGET;
3192             SvUTF8_off(TARG);                           /* decontaminate */
3193             sv_setsv(TARG, sv);
3194             sv = TARG;
3195             SETs(sv);
3196         }
3197         s = (U8*)SvPV_force(sv, slen);
3198         if (*s) {
3199             if (IN_LOCALE_RUNTIME) {
3200                 TAINT;
3201                 SvTAINTED_on(sv);
3202                 *s = toLOWER_LC(*s);
3203             }
3204             else
3205                 *s = toLOWER(*s);
3206         }
3207     }
3208     if (SvSMAGICAL(sv))
3209         mg_set(sv);
3210     RETURN;
3211 }
3212
3213 PP(pp_uc)
3214 {
3215     dSP;
3216     SV *sv = TOPs;
3217     register U8 *s;
3218     STRLEN len;
3219
3220     if (DO_UTF8(sv)) {
3221         dTARGET;
3222         STRLEN ulen;
3223         register U8 *d;
3224         U8 *send;
3225         U8 tmpbuf[UTF8_MAXLEN*2+1];
3226
3227         s = (U8*)SvPV(sv,len);
3228         if (!len) {
3229             SvUTF8_off(TARG);                           /* decontaminate */
3230             sv_setpvn(TARG, "", 0);
3231             SETs(TARG);
3232         }
3233         else {
3234             (void)SvUPGRADE(TARG, SVt_PV);
3235             SvGROW(TARG, (len * 2) + 1);
3236             (void)SvPOK_only(TARG);
3237             d = (U8*)SvPVX(TARG);
3238             send = s + len;
3239             while (s < send) {
3240                 toUPPER_utf8(s, tmpbuf, &ulen);
3241                 Copy(tmpbuf, d, ulen, U8);
3242                 d += ulen;
3243                 s += UTF8SKIP(s);
3244             }
3245             *d = '\0';
3246             SvUTF8_on(TARG);
3247             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3248             SETs(TARG);
3249         }
3250     }
3251     else {
3252         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3253             dTARGET;
3254             SvUTF8_off(TARG);                           /* decontaminate */
3255             sv_setsv(TARG, sv);
3256             sv = TARG;
3257             SETs(sv);
3258         }
3259         s = (U8*)SvPV_force(sv, len);
3260         if (len) {
3261             register U8 *send = s + len;
3262
3263             if (IN_LOCALE_RUNTIME) {
3264                 TAINT;
3265                 SvTAINTED_on(sv);
3266                 for (; s < send; s++)
3267                     *s = toUPPER_LC(*s);
3268             }
3269             else {
3270                 for (; s < send; s++)
3271                     *s = toUPPER(*s);
3272             }
3273         }
3274     }
3275     if (SvSMAGICAL(sv))
3276         mg_set(sv);
3277     RETURN;
3278 }
3279
3280 PP(pp_lc)
3281 {
3282     dSP;
3283     SV *sv = TOPs;
3284     register U8 *s;
3285     STRLEN len;
3286
3287     if (DO_UTF8(sv)) {
3288         dTARGET;
3289         STRLEN ulen;
3290         register U8 *d;
3291         U8 *send;
3292         U8 tmpbuf[UTF8_MAXLEN*2+1];
3293
3294         s = (U8*)SvPV(sv,len);
3295         if (!len) {
3296             SvUTF8_off(TARG);                           /* decontaminate */
3297             sv_setpvn(TARG, "", 0);
3298             SETs(TARG);
3299         }
3300         else {
3301             (void)SvUPGRADE(TARG, SVt_PV);
3302             SvGROW(TARG, (len * 2) + 1);
3303             (void)SvPOK_only(TARG);
3304             d = (U8*)SvPVX(TARG);
3305             send = s + len;
3306             while (s < send) {
3307                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3308 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3309                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3310                      /*
3311                       * Now if the sigma is NOT followed by
3312                       * /$ignorable_sequence$cased_letter/;
3313                       * and it IS preceded by
3314                       * /$cased_letter$ignorable_sequence/;
3315                       * where $ignorable_sequence is
3316                       * [\x{2010}\x{AD}\p{Mn}]*
3317                       * and $cased_letter is
3318                       * [\p{Ll}\p{Lo}\p{Lt}]
3319                       * then it should be mapped to 0x03C2,
3320                       * (GREEK SMALL LETTER FINAL SIGMA),
3321                       * instead of staying 0x03A3.
3322                       * See lib/unicore/SpecCase.txt.
3323                       */
3324                 }
3325                 Copy(tmpbuf, d, ulen, U8);
3326                 d += ulen;
3327                 s += UTF8SKIP(s);
3328             }
3329             *d = '\0';
3330             SvUTF8_on(TARG);
3331             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3332             SETs(TARG);
3333         }
3334     }
3335     else {
3336         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3337             dTARGET;
3338             SvUTF8_off(TARG);                           /* decontaminate */
3339             sv_setsv(TARG, sv);
3340             sv = TARG;
3341             SETs(sv);
3342         }
3343
3344         s = (U8*)SvPV_force(sv, len);
3345         if (len) {
3346             register U8 *send = s + len;
3347
3348             if (IN_LOCALE_RUNTIME) {
3349                 TAINT;
3350                 SvTAINTED_on(sv);
3351                 for (; s < send; s++)
3352                     *s = toLOWER_LC(*s);
3353             }
3354             else {
3355                 for (; s < send; s++)
3356                     *s = toLOWER(*s);
3357             }
3358         }
3359     }
3360     if (SvSMAGICAL(sv))
3361         mg_set(sv);
3362     RETURN;
3363 }
3364
3365 PP(pp_quotemeta)
3366 {
3367     dSP; dTARGET;
3368     SV *sv = TOPs;
3369     STRLEN len;
3370     register char *s = SvPV(sv,len);
3371     register char *d;
3372
3373     SvUTF8_off(TARG);                           /* decontaminate */
3374     if (len) {
3375         (void)SvUPGRADE(TARG, SVt_PV);
3376         SvGROW(TARG, (len * 2) + 1);
3377         d = SvPVX(TARG);
3378         if (DO_UTF8(sv)) {
3379             while (len) {
3380                 if (UTF8_IS_CONTINUED(*s)) {
3381                     STRLEN ulen = UTF8SKIP(s);
3382                     if (ulen > len)
3383                         ulen = len;
3384                     len -= ulen;
3385                     while (ulen--)
3386                         *d++ = *s++;
3387                 }
3388                 else {
3389                     if (!isALNUM(*s))
3390                         *d++ = '\\';
3391                     *d++ = *s++;
3392                     len--;
3393                 }
3394             }
3395             SvUTF8_on(TARG);
3396         }
3397         else {
3398             while (len--) {
3399                 if (!isALNUM(*s))
3400                     *d++ = '\\';
3401                 *d++ = *s++;
3402             }
3403         }
3404         *d = '\0';
3405         SvCUR_set(TARG, d - SvPVX(TARG));
3406         (void)SvPOK_only_UTF8(TARG);
3407     }
3408     else
3409         sv_setpvn(TARG, s, len);
3410     SETs(TARG);
3411     if (SvSMAGICAL(TARG))
3412         mg_set(TARG);
3413     RETURN;
3414 }
3415
3416 /* Arrays. */
3417
3418 PP(pp_aslice)
3419 {
3420     dSP; dMARK; dORIGMARK;
3421     register SV** svp;
3422     register AV* av = (AV*)POPs;
3423     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3424     I32 arybase = PL_curcop->cop_arybase;
3425     I32 elem;
3426
3427     if (SvTYPE(av) == SVt_PVAV) {
3428         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3429             I32 max = -1;
3430             for (svp = MARK + 1; svp <= SP; svp++) {
3431                 elem = SvIVx(*svp);
3432                 if (elem > max)
3433                     max = elem;
3434             }
3435             if (max > AvMAX(av))
3436                 av_extend(av, max);
3437         }
3438         while (++MARK <= SP) {
3439             elem = SvIVx(*MARK);
3440
3441             if (elem > 0)
3442                 elem -= arybase;
3443             svp = av_fetch(av, elem, lval);
3444             if (lval) {
3445                 if (!svp || *svp == &PL_sv_undef)
3446                     DIE(aTHX_ PL_no_aelem, elem);
3447                 if (PL_op->op_private & OPpLVAL_INTRO)
3448                     save_aelem(av, elem, svp);
3449             }
3450             *MARK = svp ? *svp : &PL_sv_undef;
3451         }
3452     }
3453     if (GIMME != G_ARRAY) {
3454         MARK = ORIGMARK;
3455         *++MARK = *SP;
3456         SP = MARK;
3457     }
3458     RETURN;
3459 }
3460
3461 /* Associative arrays. */
3462
3463 PP(pp_each)
3464 {
3465     dSP;
3466     HV *hash = (HV*)POPs;
3467     HE *entry;
3468     I32 gimme = GIMME_V;
3469     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3470
3471     PUTBACK;
3472     /* might clobber stack_sp */
3473     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3474     SPAGAIN;
3475
3476     EXTEND(SP, 2);
3477     if (entry) {
3478         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
3479         if (gimme == G_ARRAY) {
3480             SV *val;
3481             PUTBACK;
3482             /* might clobber stack_sp */
3483             val = realhv ?
3484                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3485             SPAGAIN;
3486             PUSHs(val);
3487         }
3488     }
3489     else if (gimme == G_SCALAR)
3490         RETPUSHUNDEF;
3491
3492     RETURN;
3493 }
3494
3495 PP(pp_values)
3496 {
3497     return do_kv();
3498 }
3499
3500 PP(pp_keys)
3501 {
3502     return do_kv();
3503 }
3504
3505 PP(pp_delete)
3506 {
3507     dSP;
3508     I32 gimme = GIMME_V;
3509     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3510     SV *sv;
3511     HV *hv;
3512
3513     if (PL_op->op_private & OPpSLICE) {
3514         dMARK; dORIGMARK;
3515         U32 hvtype;
3516         hv = (HV*)POPs;
3517         hvtype = SvTYPE(hv);
3518         if (hvtype == SVt_PVHV) {                       /* hash element */
3519             while (++MARK <= SP) {
3520                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3521                 *MARK = sv ? sv : &PL_sv_undef;
3522             }
3523         }
3524         else if (hvtype == SVt_PVAV) {
3525             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
3526                 while (++MARK <= SP) {
3527                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3528                     *MARK = sv ? sv : &PL_sv_undef;
3529                 }
3530             }
3531             else {                                      /* pseudo-hash element */
3532                 while (++MARK <= SP) {
3533                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3534                     *MARK = sv ? sv : &PL_sv_undef;
3535                 }
3536             }
3537         }
3538         else
3539             DIE(aTHX_ "Not a HASH reference");
3540         if (discard)
3541             SP = ORIGMARK;
3542         else if (gimme == G_SCALAR) {
3543             MARK = ORIGMARK;
3544             *++MARK = *SP;
3545             SP = MARK;
3546         }
3547     }
3548     else {
3549         SV *keysv = POPs;
3550         hv = (HV*)POPs;
3551         if (SvTYPE(hv) == SVt_PVHV)
3552             sv = hv_delete_ent(hv, keysv, discard, 0);
3553         else if (SvTYPE(hv) == SVt_PVAV) {
3554             if (PL_op->op_flags & OPf_SPECIAL)
3555                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3556             else
3557                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3558         }
3559         else
3560             DIE(aTHX_ "Not a HASH reference");
3561         if (!sv)
3562             sv = &PL_sv_undef;
3563         if (!discard)
3564             PUSHs(sv);
3565     }
3566     RETURN;
3567 }
3568
3569 PP(pp_exists)
3570 {
3571     dSP;
3572     SV *tmpsv;
3573     HV *hv;
3574
3575     if (PL_op->op_private & OPpEXISTS_SUB) {
3576         GV *gv;
3577         CV *cv;
3578         SV *sv = POPs;
3579         cv = sv_2cv(sv, &hv, &gv, FALSE);
3580         if (cv)
3581             RETPUSHYES;
3582         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3583             RETPUSHYES;
3584         RETPUSHNO;
3585     }
3586     tmpsv = POPs;
3587     hv = (HV*)POPs;
3588     if (SvTYPE(hv) == SVt_PVHV) {
3589         if (hv_exists_ent(hv, tmpsv, 0))
3590             RETPUSHYES;
3591     }
3592     else if (SvTYPE(hv) == SVt_PVAV) {
3593         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3594             if (av_exists((AV*)hv, SvIV(tmpsv)))
3595                 RETPUSHYES;
3596         }
3597         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
3598             RETPUSHYES;
3599     }
3600     else {
3601         DIE(aTHX_ "Not a HASH reference");
3602     }
3603     RETPUSHNO;
3604 }
3605
3606 PP(pp_hslice)
3607 {
3608     dSP; dMARK; dORIGMARK;
3609     register HV *hv = (HV*)POPs;
3610     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3611     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3612
3613     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3614         DIE(aTHX_ "Can't localize pseudo-hash element");
3615
3616     if (realhv || SvTYPE(hv) == SVt_PVAV) {
3617         while (++MARK <= SP) {
3618             SV *keysv = *MARK;
3619             SV **svp;
3620             I32 preeminent = SvRMAGICAL(hv) ? 1 :
3621                                 realhv ? hv_exists_ent(hv, keysv, 0)
3622                                        : avhv_exists_ent((AV*)hv, keysv, 0);
3623             if (realhv) {
3624                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3625                 svp = he ? &HeVAL(he) : 0;
3626             }
3627             else {
3628                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3629             }
3630             if (lval) {
3631                 if (!svp || *svp == &PL_sv_undef) {
3632                     STRLEN n_a;
3633                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3634                 }
3635                 if (PL_op->op_private & OPpLVAL_INTRO) {
3636                     if (preeminent)
3637                         save_helem(hv, keysv, svp);
3638                     else {
3639                         STRLEN keylen;
3640                         char *key = SvPV(keysv, keylen);
3641                         SAVEDELETE(hv, savepvn(key,keylen), keylen);
3642                     }
3643                 }
3644             }
3645             *MARK = svp ? *svp : &PL_sv_undef;
3646         }
3647     }
3648     if (GIMME != G_ARRAY) {
3649         MARK = ORIGMARK;
3650         *++MARK = *SP;
3651         SP = MARK;
3652     }
3653     RETURN;
3654 }
3655
3656 /* List operators. */
3657
3658 PP(pp_list)
3659 {
3660     dSP; dMARK;
3661     if (GIMME != G_ARRAY) {
3662         if (++MARK <= SP)
3663             *MARK = *SP;                /* unwanted list, return last item */
3664         else
3665             *MARK = &PL_sv_undef;
3666         SP = MARK;
3667     }
3668     RETURN;
3669 }
3670
3671 PP(pp_lslice)
3672 {
3673     dSP;
3674     SV **lastrelem = PL_stack_sp;
3675     SV **lastlelem = PL_stack_base + POPMARK;
3676     SV **firstlelem = PL_stack_base + POPMARK + 1;
3677     register SV **firstrelem = lastlelem + 1;
3678     I32 arybase = PL_curcop->cop_arybase;
3679     I32 lval = PL_op->op_flags & OPf_MOD;
3680     I32 is_something_there = lval;
3681
3682     register I32 max = lastrelem - lastlelem;
3683     register SV **lelem;
3684     register I32 ix;
3685
3686     if (GIMME != G_ARRAY) {
3687         ix = SvIVx(*lastlelem);
3688         if (ix < 0)
3689             ix += max;
3690         else
3691             ix -= arybase;
3692         if (ix < 0 || ix >= max)
3693             *firstlelem = &PL_sv_undef;
3694         else
3695             *firstlelem = firstrelem[ix];
3696         SP = firstlelem;
3697         RETURN;
3698     }
3699
3700     if (max == 0) {
3701         SP = firstlelem - 1;
3702         RETURN;
3703     }
3704
3705     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3706         ix = SvIVx(*lelem);
3707         if (ix < 0)
3708             ix += max;
3709         else
3710             ix -= arybase;
3711         if (ix < 0 || ix >= max)
3712             *lelem = &PL_sv_undef;
3713         else {
3714             is_something_there = TRUE;
3715             if (!(*lelem = firstrelem[ix]))
3716                 *lelem = &PL_sv_undef;
3717         }
3718     }
3719     if (is_something_there)
3720         SP = lastlelem;
3721     else
3722         SP = firstlelem - 1;
3723     RETURN;
3724 }
3725
3726 PP(pp_anonlist)
3727 {
3728     dSP; dMARK; dORIGMARK;
3729     I32 items = SP - MARK;
3730     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3731     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3732     XPUSHs(av);
3733     RETURN;
3734 }
3735
3736 PP(pp_anonhash)
3737 {
3738     dSP; dMARK; dORIGMARK;
3739     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3740
3741     while (MARK < SP) {
3742         SV* key = *++MARK;
3743         SV *val = NEWSV(46, 0);
3744         if (MARK < SP)
3745             sv_setsv(val, *++MARK);
3746         else if (ckWARN(WARN_MISC))
3747             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3748         (void)hv_store_ent(hv,key,val,0);
3749     }
3750     SP = ORIGMARK;
3751     XPUSHs((SV*)hv);
3752     RETURN;
3753 }
3754
3755 PP(pp_splice)
3756 {
3757     dSP; dMARK; dORIGMARK;
3758     register AV *ary = (AV*)*++MARK;
3759     register SV **src;
3760     register SV **dst;
3761     register I32 i;
3762     register I32 offset;
3763     register I32 length;
3764     I32 newlen;
3765     I32 after;
3766     I32 diff;
3767     SV **tmparyval = 0;
3768     MAGIC *mg;
3769
3770     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3771         *MARK-- = SvTIED_obj((SV*)ary, mg);
3772         PUSHMARK(MARK);
3773         PUTBACK;
3774         ENTER;
3775         call_method("SPLICE",GIMME_V);
3776         LEAVE;
3777         SPAGAIN;
3778         RETURN;
3779     }
3780
3781     SP++;
3782
3783     if (++MARK < SP) {
3784         offset = i = SvIVx(*MARK);
3785         if (offset < 0)
3786             offset += AvFILLp(ary) + 1;
3787         else
3788             offset -= PL_curcop->cop_arybase;
3789         if (offset < 0)
3790             DIE(aTHX_ PL_no_aelem, i);
3791         if (++MARK < SP) {
3792             length = SvIVx(*MARK++);
3793             if (length < 0) {
3794                 length += AvFILLp(ary) - offset + 1;
3795                 if (length < 0)
3796                     length = 0;
3797             }
3798         }
3799         else
3800             length = AvMAX(ary) + 1;            /* close enough to infinity */
3801     }
3802     else {
3803         offset = 0;
3804         length = AvMAX(ary) + 1;
3805     }
3806     if (offset > AvFILLp(ary) + 1)
3807         offset = AvFILLp(ary) + 1;
3808     after = AvFILLp(ary) + 1 - (offset + length);
3809     if (after < 0) {                            /* not that much array */
3810         length += after;                        /* offset+length now in array */
3811         after = 0;
3812         if (!AvALLOC(ary))
3813             av_extend(ary, 0);
3814     }
3815
3816     /* At this point, MARK .. SP-1 is our new LIST */
3817
3818     newlen = SP - MARK;
3819     diff = newlen - length;
3820     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3821         av_reify(ary);
3822
3823     if (diff < 0) {                             /* shrinking the area */
3824         if (newlen) {
3825             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3826             Copy(MARK, tmparyval, newlen, SV*);
3827         }
3828
3829         MARK = ORIGMARK + 1;
3830         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3831             MEXTEND(MARK, length);
3832             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3833             if (AvREAL(ary)) {
3834                 EXTEND_MORTAL(length);
3835                 for (i = length, dst = MARK; i; i--) {
3836                     sv_2mortal(*dst);   /* free them eventualy */
3837                     dst++;
3838                 }
3839             }
3840             MARK += length - 1;
3841         }
3842         else {
3843             *MARK = AvARRAY(ary)[offset+length-1];
3844             if (AvREAL(ary)) {
3845                 sv_2mortal(*MARK);
3846                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3847                     SvREFCNT_dec(*dst++);       /* free them now */
3848             }
3849         }
3850         AvFILLp(ary) += diff;
3851
3852         /* pull up or down? */
3853
3854         if (offset < after) {                   /* easier to pull up */
3855             if (offset) {                       /* esp. if nothing to pull */
3856                 src = &AvARRAY(ary)[offset-1];
3857                 dst = src - diff;               /* diff is negative */
3858                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3859                     *dst-- = *src--;
3860             }
3861             dst = AvARRAY(ary);
3862             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3863             AvMAX(ary) += diff;
3864         }
3865         else {
3866             if (after) {                        /* anything to pull down? */
3867                 src = AvARRAY(ary) + offset + length;
3868                 dst = src + diff;               /* diff is negative */
3869                 Move(src, dst, after, SV*);
3870             }
3871             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3872                                                 /* avoid later double free */
3873         }
3874         i = -diff;
3875         while (i)
3876             dst[--i] = &PL_sv_undef;
3877
3878         if (newlen) {
3879             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3880               newlen; newlen--) {
3881                 *dst = NEWSV(46, 0);
3882                 sv_setsv(*dst++, *src++);
3883             }
3884             Safefree(tmparyval);
3885         }
3886     }
3887     else {                                      /* no, expanding (or same) */
3888         if (length) {
3889             New(452, tmparyval, length, SV*);   /* so remember deletion */
3890             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3891         }
3892
3893         if (diff > 0) {                         /* expanding */
3894
3895             /* push up or down? */
3896
3897             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3898                 if (offset) {
3899                     src = AvARRAY(ary);
3900                     dst = src - diff;
3901                     Move(src, dst, offset, SV*);
3902                 }
3903                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3904                 AvMAX(ary) += diff;
3905                 AvFILLp(ary) += diff;
3906             }
3907             else {
3908                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3909                     av_extend(ary, AvFILLp(ary) + diff);
3910                 AvFILLp(ary) += diff;
3911
3912                 if (after) {
3913                     dst = AvARRAY(ary) + AvFILLp(ary);
3914                     src = dst - diff;
3915                     for (i = after; i; i--) {
3916                         *dst-- = *src--;
3917                     }
3918                 }
3919             }
3920         }
3921
3922         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3923             *dst = NEWSV(46, 0);
3924             sv_setsv(*dst++, *src++);
3925         }
3926         MARK = ORIGMARK + 1;
3927         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3928             if (length) {
3929                 Copy(tmparyval, MARK, length, SV*);
3930                 if (AvREAL(ary)) {
3931                     EXTEND_MORTAL(length);
3932                     for (i = length, dst = MARK; i; i--) {
3933                         sv_2mortal(*dst);       /* free them eventualy */
3934                         dst++;
3935                     }
3936                 }
3937                 Safefree(tmparyval);
3938             }
3939             MARK += length - 1;
3940         }
3941         else if (length--) {
3942             *MARK = tmparyval[length];
3943             if (AvREAL(ary)) {
3944                 sv_2mortal(*MARK);
3945                 while (length-- > 0)
3946                     SvREFCNT_dec(tmparyval[length]);
3947             }
3948             Safefree(tmparyval);
3949         }
3950         else
3951             *MARK = &PL_sv_undef;
3952     }
3953     SP = MARK;
3954     RETURN;
3955 }
3956
3957 PP(pp_push)
3958 {
3959     dSP; dMARK; dORIGMARK; dTARGET;
3960     register AV *ary = (AV*)*++MARK;
3961     register SV *sv = &PL_sv_undef;
3962     MAGIC *mg;
3963
3964     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3965         *MARK-- = SvTIED_obj((SV*)ary, mg);
3966         PUSHMARK(MARK);
3967         PUTBACK;
3968         ENTER;
3969         call_method("PUSH",G_SCALAR|G_DISCARD);
3970         LEAVE;
3971         SPAGAIN;
3972     }
3973     else {
3974         /* Why no pre-extend of ary here ? */
3975         for (++MARK; MARK <= SP; MARK++) {
3976             sv = NEWSV(51, 0);
3977             if (*MARK)
3978                 sv_setsv(sv, *MARK);
3979             av_push(ary, sv);
3980         }
3981     }
3982     SP = ORIGMARK;
3983     PUSHi( AvFILL(ary) + 1 );
3984     RETURN;
3985 }
3986
3987 PP(pp_pop)
3988 {
3989     dSP;
3990     AV *av = (AV*)POPs;
3991     SV *sv = av_pop(av);
3992     if (AvREAL(av))
3993         (void)sv_2mortal(sv);
3994     PUSHs(sv);
3995     RETURN;
3996 }
3997
3998 PP(pp_shift)
3999 {
4000     dSP;
4001     AV *av = (AV*)POPs;
4002     SV *sv = av_shift(av);
4003     EXTEND(SP, 1);
4004     if (!sv)
4005         RETPUSHUNDEF;
4006     if (AvREAL(av))
4007         (void)sv_2mortal(sv);
4008     PUSHs(sv);
4009     RETURN;
4010 }
4011
4012 PP(pp_unshift)
4013 {
4014     dSP; dMARK; dORIGMARK; dTARGET;
4015     register AV *ary = (AV*)*++MARK;
4016     register SV *sv;
4017     register I32 i = 0;
4018     MAGIC *mg;
4019
4020     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4021         *MARK-- = SvTIED_obj((SV*)ary, mg);
4022         PUSHMARK(MARK);
4023         PUTBACK;
4024         ENTER;
4025         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4026         LEAVE;
4027         SPAGAIN;
4028     }
4029     else {
4030         av_unshift(ary, SP - MARK);
4031         while (MARK < SP) {
4032             sv = NEWSV(27, 0);
4033             sv_setsv(sv, *++MARK);
4034             (void)av_store(ary, i++, sv);
4035         }
4036     }
4037     SP = ORIGMARK;
4038     PUSHi( AvFILL(ary) + 1 );
4039     RETURN;
4040 }
4041
4042 PP(pp_reverse)
4043 {
4044     dSP; dMARK;
4045     register SV *tmp;
4046     SV **oldsp = SP;
4047
4048     if (GIMME == G_ARRAY) {
4049         MARK++;
4050         while (MARK < SP) {
4051             tmp = *MARK;
4052             *MARK++ = *SP;
4053             *SP-- = tmp;
4054         }
4055         /* safe as long as stack cannot get extended in the above */
4056         SP = oldsp;
4057     }
4058     else {
4059         register char *up;
4060         register char *down;
4061         register I32 tmp;
4062         dTARGET;
4063         STRLEN len;
4064
4065         SvUTF8_off(TARG);                               /* decontaminate */
4066         if (SP - MARK > 1)
4067             do_join(TARG, &PL_sv_no, MARK, SP);
4068         else
4069             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4070         up = SvPV_force(TARG, len);
4071         if (len > 1) {
4072             if (DO_UTF8(TARG)) {        /* first reverse each character */
4073                 U8* s = (U8*)SvPVX(TARG);
4074                 U8* send = (U8*)(s + len);
4075                 while (s < send) {
4076                     if (UTF8_IS_INVARIANT(*s)) {
4077                         s++;
4078                         continue;
4079                     }
4080                     else {
4081                         if (!utf8_to_uvchr(s, 0))
4082                             break;
4083                         up = (char*)s;
4084                         s += UTF8SKIP(s);
4085                         down = (char*)(s - 1);
4086                         /* reverse this character */
4087                         while (down > up) {
4088                             tmp = *up;
4089                             *up++ = *down;
4090                             *down-- = tmp;
4091                         }
4092                     }
4093                 }
4094                 up = SvPVX(TARG);
4095             }
4096             down = SvPVX(TARG) + len - 1;
4097             while (down > up) {
4098                 tmp = *up;
4099                 *up++ = *down;
4100                 *down-- = tmp;
4101             }
4102             (void)SvPOK_only_UTF8(TARG);
4103         }
4104         SP = MARK + 1;
4105         SETTARG;
4106     }
4107     RETURN;
4108 }
4109
4110 PP(pp_split)
4111 {
4112     dSP; dTARG;
4113     AV *ary;
4114     register IV limit = POPi;                   /* note, negative is forever */
4115     SV *sv = POPs;
4116     STRLEN len;
4117     register char *s = SvPV(sv, len);
4118     bool do_utf8 = DO_UTF8(sv);
4119     char *strend = s + len;
4120     register PMOP *pm;
4121     register REGEXP *rx;
4122     register SV *dstr;
4123     register char *m;
4124     I32 iters = 0;
4125     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4126     I32 maxiters = slen + 10;
4127     I32 i;
4128     char *orig;
4129     I32 origlimit = limit;
4130     I32 realarray = 0;
4131     I32 base;
4132     AV *oldstack = PL_curstack;
4133     I32 gimme = GIMME_V;
4134     I32 oldsave = PL_savestack_ix;
4135     I32 make_mortal = 1;
4136     MAGIC *mg = (MAGIC *) NULL;
4137
4138 #ifdef DEBUGGING
4139     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4140 #else
4141     pm = (PMOP*)POPs;
4142 #endif
4143     if (!pm || !s)
4144         DIE(aTHX_ "panic: pp_split");
4145     rx = PM_GETRE(pm);
4146
4147     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4148              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4149
4150     PL_reg_match_utf8 = do_utf8;
4151
4152     if (pm->op_pmreplroot) {
4153 #ifdef USE_ITHREADS
4154         ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4155 #else
4156         ary = GvAVn((GV*)pm->op_pmreplroot);
4157 #endif
4158     }
4159     else if (gimme != G_ARRAY)
4160 #ifdef USE_5005THREADS
4161         ary = (AV*)PL_curpad[0];
4162 #else
4163         ary = GvAVn(PL_defgv);
4164 #endif /* USE_5005THREADS */
4165     else
4166         ary = Nullav;
4167     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4168         realarray = 1;
4169         PUTBACK;
4170         av_extend(ary,0);
4171         av_clear(ary);
4172         SPAGAIN;
4173         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4174             PUSHMARK(SP);
4175             XPUSHs(SvTIED_obj((SV*)ary, mg));
4176         }
4177         else {
4178             if (!AvREAL(ary)) {
4179                 AvREAL_on(ary);
4180                 AvREIFY_off(ary);
4181                 for (i = AvFILLp(ary); i >= 0; i--)
4182                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4183             }
4184             /* temporarily switch stacks */
4185             SWITCHSTACK(PL_curstack, ary);
4186             make_mortal = 0;
4187         }
4188     }
4189     base = SP - PL_stack_base;
4190     orig = s;
4191     if (pm->op_pmflags & PMf_SKIPWHITE) {
4192         if (pm->op_pmflags & PMf_LOCALE) {
4193             while (isSPACE_LC(*s))
4194                 s++;
4195         }
4196         else {
4197             while (isSPACE(*s))
4198                 s++;
4199         }
4200     }
4201     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4202         SAVEINT(PL_multiline);
4203         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4204     }
4205
4206     if (!limit)
4207         limit = maxiters + 2;
4208     if (pm->op_pmflags & PMf_WHITE) {
4209         while (--limit) {
4210             m = s;
4211             while (m < strend &&
4212                    !((pm->op_pmflags & PMf_LOCALE)
4213                      ? isSPACE_LC(*m) : isSPACE(*m)))
4214                 ++m;
4215             if (m >= strend)
4216                 break;
4217
4218             dstr = NEWSV(30, m-s);
4219             sv_setpvn(dstr, s, m-s);
4220             if (make_mortal)
4221                 sv_2mortal(dstr);
4222             if (do_utf8)
4223                 (void)SvUTF8_on(dstr);
4224             XPUSHs(dstr);
4225
4226             s = m + 1;
4227             while (s < strend &&
4228                    ((pm->op_pmflags & PMf_LOCALE)
4229                     ? isSPACE_LC(*s) : isSPACE(*s)))
4230                 ++s;
4231         }
4232     }
4233     else if (strEQ("^", rx->precomp)) {
4234         while (--limit) {
4235             /*SUPPRESS 530*/
4236             for (m = s; m < strend && *m != '\n'; m++) ;
4237             m++;
4238             if (m >= strend)
4239                 break;
4240             dstr = NEWSV(30, m-s);
4241             sv_setpvn(dstr, s, m-s);
4242             if (make_mortal)
4243                 sv_2mortal(dstr);
4244             if (do_utf8)
4245                 (void)SvUTF8_on(dstr);
4246             XPUSHs(dstr);
4247             s = m;
4248         }
4249     }
4250     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4251              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4252              && (rx->reganch & ROPT_CHECK_ALL)
4253              && !(rx->reganch & ROPT_ANCH)) {
4254         int tail = (rx->reganch & RE_INTUIT_TAIL);
4255         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4256
4257         len = rx->minlen;
4258         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4259             STRLEN n_a;
4260             char c = *SvPV(csv, n_a);
4261             while (--limit) {
4262                 /*SUPPRESS 530*/
4263                 for (m = s; m < strend && *m != c; m++) ;
4264                 if (m >= strend)
4265                     break;
4266                 dstr = NEWSV(30, m-s);
4267                 sv_setpvn(dstr, s, m-s);
4268                 if (make_mortal)
4269                     sv_2mortal(dstr);
4270                 if (do_utf8)
4271                     (void)SvUTF8_on(dstr);
4272                 XPUSHs(dstr);
4273                 /* The rx->minlen is in characters but we want to step
4274                  * s ahead by bytes. */
4275                 if (do_utf8)
4276                     s = (char*)utf8_hop((U8*)m, len);
4277                 else
4278                     s = m + len; /* Fake \n at the end */
4279             }
4280         }
4281         else {
4282 #ifndef lint
4283             while (s < strend && --limit &&
4284               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4285                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4286 #endif
4287             {
4288                 dstr = NEWSV(31, m-s);
4289                 sv_setpvn(dstr, s, m-s);
4290                 if (make_mortal)
4291                     sv_2mortal(dstr);
4292                 if (do_utf8)
4293                     (void)SvUTF8_on(dstr);
4294                 XPUSHs(dstr);
4295                 /* The rx->minlen is in characters but we want to step
4296                  * s ahead by bytes. */
4297                 if (do_utf8)
4298                     s = (char*)utf8_hop((U8*)m, len);
4299                 else
4300                     s = m + len; /* Fake \n at the end */
4301             }
4302         }
4303     }
4304     else {
4305         maxiters += slen * rx->nparens;
4306         while (s < strend && --limit
4307 /*             && (!rx->check_substr
4308                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4309                                                  0, NULL))))
4310 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4311                               1 /* minend */, sv, NULL, 0))
4312         {
4313             TAINT_IF(RX_MATCH_TAINTED(rx));
4314             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4315                 m = s;
4316                 s = orig;
4317                 orig = rx->subbeg;
4318                 s = orig + (m - s);
4319                 strend = s + (strend - m);
4320             }
4321             m = rx->startp[0] + orig;
4322             dstr = NEWSV(32, m-s);
4323             sv_setpvn(dstr, s, m-s);
4324             if (make_mortal)
4325                 sv_2mortal(dstr);
4326             if (do_utf8)
4327                 (void)SvUTF8_on(dstr);
4328             XPUSHs(dstr);
4329             if (rx->nparens) {
4330                 for (i = 1; i <= rx->nparens; i++) {
4331                     s = rx->startp[i] + orig;
4332                     m = rx->endp[i] + orig;
4333
4334                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4335                        parens that didn't match -- they should be set to
4336                        undef, not the empty string */
4337                     if (m >= orig && s >= orig) {
4338                         dstr = NEWSV(33, m-s);
4339                         sv_setpvn(dstr, s, m-s);
4340                     }
4341                     else
4342                         dstr = &PL_sv_undef;  /* undef, not "" */
4343                     if (make_mortal)
4344                         sv_2mortal(dstr);
4345                     if (do_utf8)
4346                         (void)SvUTF8_on(dstr);
4347                     XPUSHs(dstr);
4348                 }
4349             }
4350             s = rx->endp[0] + orig;
4351         }
4352     }
4353
4354     LEAVE_SCOPE(oldsave);
4355     iters = (SP - PL_stack_base) - base;
4356     if (iters > maxiters)
4357         DIE(aTHX_ "Split loop");
4358
4359     /* keep field after final delim? */
4360     if (s < strend || (iters && origlimit)) {
4361         STRLEN l = strend - s;
4362         dstr = NEWSV(34, l);
4363         sv_setpvn(dstr, s, l);
4364         if (make_mortal)
4365             sv_2mortal(dstr);
4366         if (do_utf8)
4367             (void)SvUTF8_on(dstr);
4368         XPUSHs(dstr);
4369         iters++;
4370     }
4371     else if (!origlimit) {
4372         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4373             iters--, SP--;
4374     }
4375
4376     if (realarray) {
4377         if (!mg) {
4378             SWITCHSTACK(ary, oldstack);
4379             if (SvSMAGICAL(ary)) {
4380                 PUTBACK;
4381                 mg_set((SV*)ary);
4382                 SPAGAIN;
4383             }
4384             if (gimme == G_ARRAY) {
4385                 EXTEND(SP, iters);
4386                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4387                 SP += iters;
4388                 RETURN;
4389             }
4390         }
4391         else {
4392             PUTBACK;
4393             ENTER;
4394             call_method("PUSH",G_SCALAR|G_DISCARD);
4395             LEAVE;
4396             SPAGAIN;
4397             if (gimme == G_ARRAY) {
4398                 /* EXTEND should not be needed - we just popped them */
4399                 EXTEND(SP, iters);
4400                 for (i=0; i < iters; i++) {
4401                     SV **svp = av_fetch(ary, i, FALSE);
4402                     PUSHs((svp) ? *svp : &PL_sv_undef);
4403                 }
4404                 RETURN;
4405             }
4406         }
4407     }
4408     else {
4409         if (gimme == G_ARRAY)
4410             RETURN;
4411     }
4412     if (iters || !pm->op_pmreplroot) {
4413         GETTARGET;
4414         PUSHi(iters);
4415         RETURN;
4416     }
4417     RETPUSHUNDEF;
4418 }
4419
4420 #ifdef USE_5005THREADS
4421 void
4422 Perl_unlock_condpair(pTHX_ void *svv)
4423 {
4424     MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4425
4426     if (!mg)
4427         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4428     MUTEX_LOCK(MgMUTEXP(mg));
4429     if (MgOWNER(mg) != thr)
4430         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4431     MgOWNER(mg) = 0;
4432     COND_SIGNAL(MgOWNERCONDP(mg));
4433     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4434                           PTR2UV(thr), PTR2UV(svv)));
4435     MUTEX_UNLOCK(MgMUTEXP(mg));
4436 }
4437 #endif /* USE_5005THREADS */
4438
4439 PP(pp_lock)
4440 {
4441     dSP;
4442     dTOPss;
4443     SV *retsv = sv;
4444 #ifdef USE_5005THREADS
4445     sv_lock(sv);
4446 #endif /* USE_5005THREADS */
4447 #ifdef USE_ITHREADS
4448     shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4449     if(ssv)
4450         Perl_sharedsv_lock(aTHX_ ssv);
4451 #endif /* USE_ITHREADS */
4452     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4453         || SvTYPE(retsv) == SVt_PVCV) {
4454         retsv = refto(retsv);
4455     }
4456     SETs(retsv);
4457     RETURN;
4458 }
4459
4460 PP(pp_threadsv)
4461 {
4462 #ifdef USE_5005THREADS
4463     dSP;
4464     EXTEND(SP, 1);
4465     if (PL_op->op_private & OPpLVAL_INTRO)
4466         PUSHs(*save_threadsv(PL_op->op_targ));
4467     else
4468         PUSHs(THREADSV(PL_op->op_targ));
4469     RETURN;
4470 #else
4471     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4472 #endif /* USE_5005THREADS */
4473 }