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