pp.c

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