pp.c

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