pp.c

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