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 < (U32)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( -(IV)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 > (I32)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 > (I32)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, (STRLEN)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++ = (char)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) || (STRLEN)(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         PUSHs(sv);      /* won't clobber stack_sp */
3693         if (gimme == G_ARRAY) {
3694             SV *val;
3695             PUTBACK;
3696             /* might clobber stack_sp */
3697             val = realhv ?
3698                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3699             SPAGAIN;
3700             PUSHs(val);
3701         }
3702     }
3703     else if (gimme == G_SCALAR)
3704         RETPUSHUNDEF;
3705
3706     RETURN;
3707 }
3708
3709 PP(pp_values)
3710 {
3711     return do_kv();
3712 }
3713
3714 PP(pp_keys)
3715 {
3716     return do_kv();
3717 }
3718
3719 PP(pp_delete)
3720 {
3721     dSP;
3722     I32 gimme = GIMME_V;
3723     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3724     SV *sv;
3725     HV *hv;
3726
3727     if (PL_op->op_private & OPpSLICE) {
3728         dMARK; dORIGMARK;
3729         U32 hvtype;
3730         hv = (HV*)POPs;
3731         hvtype = SvTYPE(hv);
3732         if (hvtype == SVt_PVHV) {                       /* hash element */
3733             while (++MARK <= SP) {
3734                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3735                 *MARK = sv ? sv : &PL_sv_undef;
3736             }
3737         }
3738         else if (hvtype == SVt_PVAV) {
3739             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
3740                 while (++MARK <= SP) {
3741                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3742                     *MARK = sv ? sv : &PL_sv_undef;
3743                 }
3744             }
3745             else {                                      /* pseudo-hash element */
3746                 while (++MARK <= SP) {
3747                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3748                     *MARK = sv ? sv : &PL_sv_undef;
3749                 }
3750             }
3751         }
3752         else
3753             DIE(aTHX_ "Not a HASH reference");
3754         if (discard)
3755             SP = ORIGMARK;
3756         else if (gimme == G_SCALAR) {
3757             MARK = ORIGMARK;
3758             *++MARK = *SP;
3759             SP = MARK;
3760         }
3761     }
3762     else {
3763         SV *keysv = POPs;
3764         hv = (HV*)POPs;
3765         if (SvTYPE(hv) == SVt_PVHV)
3766             sv = hv_delete_ent(hv, keysv, discard, 0);
3767         else if (SvTYPE(hv) == SVt_PVAV) {
3768             if (PL_op->op_flags & OPf_SPECIAL)
3769                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3770             else
3771                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3772         }
3773         else
3774             DIE(aTHX_ "Not a HASH reference");
3775         if (!sv)
3776             sv = &PL_sv_undef;
3777         if (!discard)
3778             PUSHs(sv);
3779     }
3780     RETURN;
3781 }
3782
3783 PP(pp_exists)
3784 {
3785     dSP;
3786     SV *tmpsv;
3787     HV *hv;
3788
3789     if (PL_op->op_private & OPpEXISTS_SUB) {
3790         GV *gv;
3791         CV *cv;
3792         SV *sv = POPs;
3793         cv = sv_2cv(sv, &hv, &gv, FALSE);
3794         if (cv)
3795             RETPUSHYES;
3796         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3797             RETPUSHYES;
3798         RETPUSHNO;
3799     }
3800     tmpsv = POPs;
3801     hv = (HV*)POPs;
3802     if (SvTYPE(hv) == SVt_PVHV) {
3803         if (hv_exists_ent(hv, tmpsv, 0))
3804             RETPUSHYES;
3805     }
3806     else if (SvTYPE(hv) == SVt_PVAV) {
3807         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3808             if (av_exists((AV*)hv, SvIV(tmpsv)))
3809                 RETPUSHYES;
3810         }
3811         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
3812             RETPUSHYES;
3813     }
3814     else {
3815         DIE(aTHX_ "Not a HASH reference");
3816     }
3817     RETPUSHNO;
3818 }
3819
3820 PP(pp_hslice)
3821 {
3822     dSP; dMARK; dORIGMARK;
3823     register HV *hv = (HV*)POPs;
3824     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3825     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3826
3827     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3828         DIE(aTHX_ "Can't localize pseudo-hash element");
3829
3830     if (realhv || SvTYPE(hv) == SVt_PVAV) {
3831         while (++MARK <= SP) {
3832             SV *keysv = *MARK;
3833             SV **svp;
3834             I32 preeminent = SvRMAGICAL(hv) ? 1 :
3835                                 realhv ? hv_exists_ent(hv, keysv, 0)
3836                                        : avhv_exists_ent((AV*)hv, keysv, 0);
3837             if (realhv) {
3838                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3839                 svp = he ? &HeVAL(he) : 0;
3840             }
3841             else {
3842                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3843             }
3844             if (lval) {
3845                 if (!svp || *svp == &PL_sv_undef) {
3846                     STRLEN n_a;
3847                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3848                 }
3849                 if (PL_op->op_private & OPpLVAL_INTRO) {
3850                     if (preeminent)
3851                         save_helem(hv, keysv, svp);
3852                     else {
3853                         STRLEN keylen;
3854                         char *key = SvPV(keysv, keylen);
3855                         SAVEDELETE(hv, savepvn(key,keylen), keylen);
3856                     }
3857                 }
3858             }
3859             *MARK = svp ? *svp : &PL_sv_undef;
3860         }
3861     }
3862     if (GIMME != G_ARRAY) {
3863         MARK = ORIGMARK;
3864         *++MARK = *SP;
3865         SP = MARK;
3866     }
3867     RETURN;
3868 }
3869
3870 /* List operators. */
3871
3872 PP(pp_list)
3873 {
3874     dSP; dMARK;
3875     if (GIMME != G_ARRAY) {
3876         if (++MARK <= SP)
3877             *MARK = *SP;                /* unwanted list, return last item */
3878         else
3879             *MARK = &PL_sv_undef;
3880         SP = MARK;
3881     }
3882     RETURN;
3883 }
3884
3885 PP(pp_lslice)
3886 {
3887     dSP;
3888     SV **lastrelem = PL_stack_sp;
3889     SV **lastlelem = PL_stack_base + POPMARK;
3890     SV **firstlelem = PL_stack_base + POPMARK + 1;
3891     register SV **firstrelem = lastlelem + 1;
3892     I32 arybase = PL_curcop->cop_arybase;
3893     I32 lval = PL_op->op_flags & OPf_MOD;
3894     I32 is_something_there = lval;
3895
3896     register I32 max = lastrelem - lastlelem;
3897     register SV **lelem;
3898     register I32 ix;
3899
3900     if (GIMME != G_ARRAY) {
3901         ix = SvIVx(*lastlelem);
3902         if (ix < 0)
3903             ix += max;
3904         else
3905             ix -= arybase;
3906         if (ix < 0 || ix >= max)
3907             *firstlelem = &PL_sv_undef;
3908         else
3909             *firstlelem = firstrelem[ix];
3910         SP = firstlelem;
3911         RETURN;
3912     }
3913
3914     if (max == 0) {
3915         SP = firstlelem - 1;
3916         RETURN;
3917     }
3918
3919     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3920         ix = SvIVx(*lelem);
3921         if (ix < 0)
3922             ix += max;
3923         else
3924             ix -= arybase;
3925         if (ix < 0 || ix >= max)
3926             *lelem = &PL_sv_undef;
3927         else {
3928             is_something_there = TRUE;
3929             if (!(*lelem = firstrelem[ix]))
3930                 *lelem = &PL_sv_undef;
3931         }
3932     }
3933     if (is_something_there)
3934         SP = lastlelem;
3935     else
3936         SP = firstlelem - 1;
3937     RETURN;
3938 }
3939
3940 PP(pp_anonlist)
3941 {
3942     dSP; dMARK; dORIGMARK;
3943     I32 items = SP - MARK;
3944     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3945     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3946     XPUSHs(av);
3947     RETURN;
3948 }
3949
3950 PP(pp_anonhash)
3951 {
3952     dSP; dMARK; dORIGMARK;
3953     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3954
3955     while (MARK < SP) {
3956         SV* key = *++MARK;
3957         SV *val = NEWSV(46, 0);
3958         if (MARK < SP)
3959             sv_setsv(val, *++MARK);
3960         else if (ckWARN(WARN_MISC))
3961             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3962         (void)hv_store_ent(hv,key,val,0);
3963     }
3964     SP = ORIGMARK;
3965     XPUSHs((SV*)hv);
3966     RETURN;
3967 }
3968
3969 PP(pp_splice)
3970 {
3971     dSP; dMARK; dORIGMARK;
3972     register AV *ary = (AV*)*++MARK;
3973     register SV **src;
3974     register SV **dst;
3975     register I32 i;
3976     register I32 offset;
3977     register I32 length;
3978     I32 newlen;
3979     I32 after;
3980     I32 diff;
3981     SV **tmparyval = 0;
3982     MAGIC *mg;
3983
3984     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3985         *MARK-- = SvTIED_obj((SV*)ary, mg);
3986         PUSHMARK(MARK);
3987         PUTBACK;
3988         ENTER;
3989         call_method("SPLICE",GIMME_V);
3990         LEAVE;
3991         SPAGAIN;
3992         RETURN;
3993     }
3994
3995     SP++;
3996
3997     if (++MARK < SP) {
3998         offset = i = SvIVx(*MARK);
3999         if (offset < 0)
4000             offset += AvFILLp(ary) + 1;
4001         else
4002             offset -= PL_curcop->cop_arybase;
4003         if (offset < 0)
4004             DIE(aTHX_ PL_no_aelem, i);
4005         if (++MARK < SP) {
4006             length = SvIVx(*MARK++);
4007             if (length < 0) {
4008                 length += AvFILLp(ary) - offset + 1;
4009                 if (length < 0)
4010                     length = 0;
4011             }
4012         }
4013         else
4014             length = AvMAX(ary) + 1;            /* close enough to infinity */
4015     }
4016     else {
4017         offset = 0;
4018         length = AvMAX(ary) + 1;
4019     }
4020     if (offset > AvFILLp(ary) + 1) {
4021         if (ckWARN(WARN_MISC))
4022             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4023         offset = AvFILLp(ary) + 1;
4024     }
4025     after = AvFILLp(ary) + 1 - (offset + length);
4026     if (after < 0) {                            /* not that much array */
4027         length += after;                        /* offset+length now in array */
4028         after = 0;
4029         if (!AvALLOC(ary))
4030             av_extend(ary, 0);
4031     }
4032
4033     /* At this point, MARK .. SP-1 is our new LIST */
4034
4035     newlen = SP - MARK;
4036     diff = newlen - length;
4037     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4038         av_reify(ary);
4039
4040     if (diff < 0) {                             /* shrinking the area */
4041         if (newlen) {
4042             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4043             Copy(MARK, tmparyval, newlen, SV*);
4044         }
4045
4046         MARK = ORIGMARK + 1;
4047         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4048             MEXTEND(MARK, length);
4049             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4050             if (AvREAL(ary)) {
4051                 EXTEND_MORTAL(length);
4052                 for (i = length, dst = MARK; i; i--) {
4053                     sv_2mortal(*dst);   /* free them eventualy */
4054                     dst++;
4055                 }
4056             }
4057             MARK += length - 1;
4058         }
4059         else {
4060             *MARK = AvARRAY(ary)[offset+length-1];
4061             if (AvREAL(ary)) {
4062                 sv_2mortal(*MARK);
4063                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4064                     SvREFCNT_dec(*dst++);       /* free them now */
4065             }
4066         }
4067         AvFILLp(ary) += diff;
4068
4069         /* pull up or down? */
4070
4071         if (offset < after) {                   /* easier to pull up */
4072             if (offset) {                       /* esp. if nothing to pull */
4073                 src = &AvARRAY(ary)[offset-1];
4074                 dst = src - diff;               /* diff is negative */
4075                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4076                     *dst-- = *src--;
4077             }
4078             dst = AvARRAY(ary);
4079             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4080             AvMAX(ary) += diff;
4081         }
4082         else {
4083             if (after) {                        /* anything to pull down? */
4084                 src = AvARRAY(ary) + offset + length;
4085                 dst = src + diff;               /* diff is negative */
4086                 Move(src, dst, after, SV*);
4087             }
4088             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4089                                                 /* avoid later double free */
4090         }
4091         i = -diff;
4092         while (i)
4093             dst[--i] = &PL_sv_undef;
4094
4095         if (newlen) {
4096             for (src = tmparyval, dst = AvARRAY(ary) + offset;
4097               newlen; newlen--) {
4098                 *dst = NEWSV(46, 0);
4099                 sv_setsv(*dst++, *src++);
4100             }
4101             Safefree(tmparyval);
4102         }
4103     }
4104     else {                                      /* no, expanding (or same) */
4105         if (length) {
4106             New(452, tmparyval, length, SV*);   /* so remember deletion */
4107             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4108         }
4109
4110         if (diff > 0) {                         /* expanding */
4111
4112             /* push up or down? */
4113
4114             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4115                 if (offset) {
4116                     src = AvARRAY(ary);
4117                     dst = src - diff;
4118                     Move(src, dst, offset, SV*);
4119                 }
4120                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4121                 AvMAX(ary) += diff;
4122                 AvFILLp(ary) += diff;
4123             }
4124             else {
4125                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4126                     av_extend(ary, AvFILLp(ary) + diff);
4127                 AvFILLp(ary) += diff;
4128
4129                 if (after) {
4130                     dst = AvARRAY(ary) + AvFILLp(ary);
4131                     src = dst - diff;
4132                     for (i = after; i; i--) {
4133                         *dst-- = *src--;
4134                     }
4135                 }
4136             }
4137         }
4138
4139         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4140             *dst = NEWSV(46, 0);
4141             sv_setsv(*dst++, *src++);
4142         }
4143         MARK = ORIGMARK + 1;
4144         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4145             if (length) {
4146                 Copy(tmparyval, MARK, length, SV*);
4147                 if (AvREAL(ary)) {
4148                     EXTEND_MORTAL(length);
4149                     for (i = length, dst = MARK; i; i--) {
4150                         sv_2mortal(*dst);       /* free them eventualy */
4151                         dst++;
4152                     }
4153                 }
4154                 Safefree(tmparyval);
4155             }
4156             MARK += length - 1;
4157         }
4158         else if (length--) {
4159             *MARK = tmparyval[length];
4160             if (AvREAL(ary)) {
4161                 sv_2mortal(*MARK);
4162                 while (length-- > 0)
4163                     SvREFCNT_dec(tmparyval[length]);
4164             }
4165             Safefree(tmparyval);
4166         }
4167         else
4168             *MARK = &PL_sv_undef;
4169     }
4170     SP = MARK;
4171     RETURN;
4172 }
4173
4174 PP(pp_push)
4175 {
4176     dSP; dMARK; dORIGMARK; dTARGET;
4177     register AV *ary = (AV*)*++MARK;
4178     register SV *sv = &PL_sv_undef;
4179     MAGIC *mg;
4180
4181     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4182         *MARK-- = SvTIED_obj((SV*)ary, mg);
4183         PUSHMARK(MARK);
4184         PUTBACK;
4185         ENTER;
4186         call_method("PUSH",G_SCALAR|G_DISCARD);
4187         LEAVE;
4188         SPAGAIN;
4189     }
4190     else {
4191         /* Why no pre-extend of ary here ? */
4192         for (++MARK; MARK <= SP; MARK++) {
4193             sv = NEWSV(51, 0);
4194             if (*MARK)
4195                 sv_setsv(sv, *MARK);
4196             av_push(ary, sv);
4197         }
4198     }
4199     SP = ORIGMARK;
4200     PUSHi( AvFILL(ary) + 1 );
4201     RETURN;
4202 }
4203
4204 PP(pp_pop)
4205 {
4206     dSP;
4207     AV *av = (AV*)POPs;
4208     SV *sv = av_pop(av);
4209     if (AvREAL(av))
4210         (void)sv_2mortal(sv);
4211     PUSHs(sv);
4212     RETURN;
4213 }
4214
4215 PP(pp_shift)
4216 {
4217     dSP;
4218     AV *av = (AV*)POPs;
4219     SV *sv = av_shift(av);
4220     EXTEND(SP, 1);
4221     if (!sv)
4222         RETPUSHUNDEF;
4223     if (AvREAL(av))
4224         (void)sv_2mortal(sv);
4225     PUSHs(sv);
4226     RETURN;
4227 }
4228
4229 PP(pp_unshift)
4230 {
4231     dSP; dMARK; dORIGMARK; dTARGET;
4232     register AV *ary = (AV*)*++MARK;
4233     register SV *sv;
4234     register I32 i = 0;
4235     MAGIC *mg;
4236
4237     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4238         *MARK-- = SvTIED_obj((SV*)ary, mg);
4239         PUSHMARK(MARK);
4240         PUTBACK;
4241         ENTER;
4242         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4243         LEAVE;
4244         SPAGAIN;
4245     }
4246     else {
4247         av_unshift(ary, SP - MARK);
4248         while (MARK < SP) {
4249             sv = NEWSV(27, 0);
4250             sv_setsv(sv, *++MARK);
4251             (void)av_store(ary, i++, sv);
4252         }
4253     }
4254     SP = ORIGMARK;
4255     PUSHi( AvFILL(ary) + 1 );
4256     RETURN;
4257 }
4258
4259 PP(pp_reverse)
4260 {
4261     dSP; dMARK;
4262     register SV *tmp;
4263     SV **oldsp = SP;
4264
4265     if (GIMME == G_ARRAY) {
4266         MARK++;
4267         while (MARK < SP) {
4268             tmp = *MARK;
4269             *MARK++ = *SP;
4270             *SP-- = tmp;
4271         }
4272         /* safe as long as stack cannot get extended in the above */
4273         SP = oldsp;
4274     }
4275     else {
4276         register char *up;
4277         register char *down;
4278         register I32 tmp;
4279         dTARGET;
4280         STRLEN len;
4281
4282         SvUTF8_off(TARG);                               /* decontaminate */
4283         if (SP - MARK > 1)
4284             do_join(TARG, &PL_sv_no, MARK, SP);
4285         else
4286             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4287         up = SvPV_force(TARG, len);
4288         if (len > 1) {
4289             if (DO_UTF8(TARG)) {        /* first reverse each character */
4290                 U8* s = (U8*)SvPVX(TARG);
4291                 U8* send = (U8*)(s + len);
4292                 while (s < send) {
4293                     if (UTF8_IS_INVARIANT(*s)) {
4294                         s++;
4295                         continue;
4296                     }
4297                     else {
4298                         if (!utf8_to_uvchr(s, 0))
4299                             break;
4300                         up = (char*)s;
4301                         s += UTF8SKIP(s);
4302                         down = (char*)(s - 1);
4303                         /* reverse this character */
4304                         while (down > up) {
4305                             tmp = *up;
4306                             *up++ = *down;
4307                             *down-- = (char)tmp;
4308                         }
4309                     }
4310                 }
4311                 up = SvPVX(TARG);
4312             }
4313             down = SvPVX(TARG) + len - 1;
4314             while (down > up) {
4315                 tmp = *up;
4316                 *up++ = *down;
4317                 *down-- = (char)tmp;
4318             }
4319             (void)SvPOK_only_UTF8(TARG);
4320         }
4321         SP = MARK + 1;
4322         SETTARG;
4323     }
4324     RETURN;
4325 }
4326
4327 PP(pp_split)
4328 {
4329     dSP; dTARG;
4330     AV *ary;
4331     register IV limit = POPi;                   /* note, negative is forever */
4332     SV *sv = POPs;
4333     STRLEN len;
4334     register char *s = SvPV(sv, len);
4335     bool do_utf8 = DO_UTF8(sv);
4336     char *strend = s + len;
4337     register PMOP *pm;
4338     register REGEXP *rx;
4339     register SV *dstr;
4340     register char *m;
4341     I32 iters = 0;
4342     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4343     I32 maxiters = slen + 10;
4344     I32 i;
4345     char *orig;
4346     I32 origlimit = limit;
4347     I32 realarray = 0;
4348     I32 base;
4349     AV *oldstack = PL_curstack;
4350     I32 gimme = GIMME_V;
4351     I32 oldsave = PL_savestack_ix;
4352     I32 make_mortal = 1;
4353     MAGIC *mg = (MAGIC *) NULL;
4354
4355 #ifdef DEBUGGING
4356     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4357 #else
4358     pm = (PMOP*)POPs;
4359 #endif
4360     if (!pm || !s)
4361         DIE(aTHX_ "panic: pp_split");
4362     rx = PM_GETRE(pm);
4363
4364     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4365              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4366
4367     PL_reg_match_utf8 = do_utf8;
4368
4369     if (pm->op_pmreplroot) {
4370 #ifdef USE_ITHREADS
4371         ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4372 #else
4373         ary = GvAVn((GV*)pm->op_pmreplroot);
4374 #endif
4375     }
4376     else if (gimme != G_ARRAY)
4377 #ifdef USE_5005THREADS
4378         ary = (AV*)PL_curpad[0];
4379 #else
4380         ary = GvAVn(PL_defgv);
4381 #endif /* USE_5005THREADS */
4382     else
4383         ary = Nullav;
4384     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4385         realarray = 1;
4386         PUTBACK;
4387         av_extend(ary,0);
4388         av_clear(ary);
4389         SPAGAIN;
4390         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4391             PUSHMARK(SP);
4392             XPUSHs(SvTIED_obj((SV*)ary, mg));
4393         }
4394         else {
4395             if (!AvREAL(ary)) {
4396                 AvREAL_on(ary);
4397                 AvREIFY_off(ary);
4398                 for (i = AvFILLp(ary); i >= 0; i--)
4399                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4400             }
4401             /* temporarily switch stacks */
4402             SWITCHSTACK(PL_curstack, ary);
4403             make_mortal = 0;
4404         }
4405     }
4406     base = SP - PL_stack_base;
4407     orig = s;
4408     if (pm->op_pmflags & PMf_SKIPWHITE) {
4409         if (pm->op_pmflags & PMf_LOCALE) {
4410             while (isSPACE_LC(*s))
4411                 s++;
4412         }
4413         else {
4414             while (isSPACE(*s))
4415                 s++;
4416         }
4417     }
4418     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4419         SAVEINT(PL_multiline);
4420         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4421     }
4422
4423     if (!limit)
4424         limit = maxiters + 2;
4425     if (pm->op_pmflags & PMf_WHITE) {
4426         while (--limit) {
4427             m = s;
4428             while (m < strend &&
4429                    !((pm->op_pmflags & PMf_LOCALE)
4430                      ? isSPACE_LC(*m) : isSPACE(*m)))
4431                 ++m;
4432             if (m >= strend)
4433                 break;
4434
4435             dstr = NEWSV(30, m-s);
4436             sv_setpvn(dstr, s, m-s);
4437             if (make_mortal)
4438                 sv_2mortal(dstr);
4439             if (do_utf8)
4440                 (void)SvUTF8_on(dstr);
4441             XPUSHs(dstr);
4442
4443             s = m + 1;
4444             while (s < strend &&
4445                    ((pm->op_pmflags & PMf_LOCALE)
4446                     ? isSPACE_LC(*s) : isSPACE(*s)))
4447                 ++s;
4448         }
4449     }
4450     else if (strEQ("^", rx->precomp)) {
4451         while (--limit) {
4452             /*SUPPRESS 530*/
4453             for (m = s; m < strend && *m != '\n'; m++) ;
4454             m++;
4455             if (m >= strend)
4456                 break;
4457             dstr = NEWSV(30, m-s);
4458             sv_setpvn(dstr, s, m-s);
4459             if (make_mortal)
4460                 sv_2mortal(dstr);
4461             if (do_utf8)
4462                 (void)SvUTF8_on(dstr);
4463             XPUSHs(dstr);
4464             s = m;
4465         }
4466     }
4467     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4468              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4469              && (rx->reganch & ROPT_CHECK_ALL)
4470              && !(rx->reganch & ROPT_ANCH)) {
4471         int tail = (rx->reganch & RE_INTUIT_TAIL);
4472         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4473
4474         len = rx->minlen;
4475         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4476             STRLEN n_a;
4477             char c = *SvPV(csv, n_a);
4478             while (--limit) {
4479                 /*SUPPRESS 530*/
4480                 for (m = s; m < strend && *m != c; m++) ;
4481                 if (m >= strend)
4482                     break;
4483                 dstr = NEWSV(30, m-s);
4484                 sv_setpvn(dstr, s, m-s);
4485                 if (make_mortal)
4486                     sv_2mortal(dstr);
4487                 if (do_utf8)
4488                     (void)SvUTF8_on(dstr);
4489                 XPUSHs(dstr);
4490                 /* The rx->minlen is in characters but we want to step
4491                  * s ahead by bytes. */
4492                 if (do_utf8)
4493                     s = (char*)utf8_hop((U8*)m, len);
4494                 else
4495                     s = m + len; /* Fake \n at the end */
4496             }
4497         }
4498         else {
4499 #ifndef lint
4500             while (s < strend && --limit &&
4501               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4502                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4503 #endif
4504             {
4505                 dstr = NEWSV(31, m-s);
4506                 sv_setpvn(dstr, s, m-s);
4507                 if (make_mortal)
4508                     sv_2mortal(dstr);
4509                 if (do_utf8)
4510                     (void)SvUTF8_on(dstr);
4511                 XPUSHs(dstr);
4512                 /* The rx->minlen is in characters but we want to step
4513                  * s ahead by bytes. */
4514                 if (do_utf8)
4515                     s = (char*)utf8_hop((U8*)m, len);
4516                 else
4517                     s = m + len; /* Fake \n at the end */
4518             }
4519         }
4520     }
4521     else {
4522         maxiters += slen * rx->nparens;
4523         while (s < strend && --limit
4524 /*             && (!rx->check_substr
4525                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4526                                                  0, NULL))))
4527 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4528                               1 /* minend */, sv, NULL, 0))
4529         {
4530             TAINT_IF(RX_MATCH_TAINTED(rx));
4531             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4532                 m = s;
4533                 s = orig;
4534                 orig = rx->subbeg;
4535                 s = orig + (m - s);
4536                 strend = s + (strend - m);
4537             }
4538             m = rx->startp[0] + orig;
4539             dstr = NEWSV(32, m-s);
4540             sv_setpvn(dstr, s, m-s);
4541             if (make_mortal)
4542                 sv_2mortal(dstr);
4543             if (do_utf8)
4544                 (void)SvUTF8_on(dstr);
4545             XPUSHs(dstr);
4546             if (rx->nparens) {
4547                 for (i = 1; i <= (I32)rx->nparens; i++) {
4548                     s = rx->startp[i] + orig;
4549                     m = rx->endp[i] + orig;
4550
4551                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4552                        parens that didn't match -- they should be set to
4553                        undef, not the empty string */
4554                     if (m >= orig && s >= orig) {
4555                         dstr = NEWSV(33, m-s);
4556                         sv_setpvn(dstr, s, m-s);
4557                     }
4558                     else
4559                         dstr = &PL_sv_undef;  /* undef, not "" */
4560                     if (make_mortal)
4561                         sv_2mortal(dstr);
4562                     if (do_utf8)
4563                         (void)SvUTF8_on(dstr);
4564                     XPUSHs(dstr);
4565                 }
4566             }
4567             s = rx->endp[0] + orig;
4568         }
4569     }
4570
4571     LEAVE_SCOPE(oldsave);
4572     iters = (SP - PL_stack_base) - base;
4573     if (iters > maxiters)
4574         DIE(aTHX_ "Split loop");
4575
4576     /* keep field after final delim? */
4577     if (s < strend || (iters && origlimit)) {
4578         STRLEN l = strend - s;
4579         dstr = NEWSV(34, l);
4580         sv_setpvn(dstr, s, l);
4581         if (make_mortal)
4582             sv_2mortal(dstr);
4583         if (do_utf8)
4584             (void)SvUTF8_on(dstr);
4585         XPUSHs(dstr);
4586         iters++;
4587     }
4588     else if (!origlimit) {
4589         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4590             iters--, SP--;
4591     }
4592
4593     if (realarray) {
4594         if (!mg) {
4595             SWITCHSTACK(ary, oldstack);
4596             if (SvSMAGICAL(ary)) {
4597                 PUTBACK;
4598                 mg_set((SV*)ary);
4599                 SPAGAIN;
4600             }
4601             if (gimme == G_ARRAY) {
4602                 EXTEND(SP, iters);
4603                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4604                 SP += iters;
4605                 RETURN;
4606             }
4607         }
4608         else {
4609             PUTBACK;
4610             ENTER;
4611             call_method("PUSH",G_SCALAR|G_DISCARD);
4612             LEAVE;
4613             SPAGAIN;
4614             if (gimme == G_ARRAY) {
4615                 /* EXTEND should not be needed - we just popped them */
4616                 EXTEND(SP, iters);
4617                 for (i=0; i < iters; i++) {
4618                     SV **svp = av_fetch(ary, i, FALSE);
4619                     PUSHs((svp) ? *svp : &PL_sv_undef);
4620                 }
4621                 RETURN;
4622             }
4623         }
4624     }
4625     else {
4626         if (gimme == G_ARRAY)
4627             RETURN;
4628     }
4629     if (iters || !pm->op_pmreplroot) {
4630         GETTARGET;
4631         PUSHi(iters);
4632         RETURN;
4633     }
4634     RETPUSHUNDEF;
4635 }
4636
4637 #ifdef USE_5005THREADS
4638 void
4639 Perl_unlock_condpair(pTHX_ void *svv)
4640 {
4641     MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4642
4643     if (!mg)
4644         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4645     MUTEX_LOCK(MgMUTEXP(mg));
4646     if (MgOWNER(mg) != thr)
4647         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4648     MgOWNER(mg) = 0;
4649     COND_SIGNAL(MgOWNERCONDP(mg));
4650     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4651                           PTR2UV(thr), PTR2UV(svv)));
4652     MUTEX_UNLOCK(MgMUTEXP(mg));
4653 }
4654 #endif /* USE_5005THREADS */
4655
4656 PP(pp_lock)
4657 {
4658     dSP;
4659     dTOPss;
4660     SV *retsv = sv;
4661     SvLOCK(sv);
4662     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4663         || SvTYPE(retsv) == SVt_PVCV) {
4664         retsv = refto(retsv);
4665     }
4666     SETs(retsv);
4667     RETURN;
4668 }
4669
4670 PP(pp_threadsv)
4671 {
4672 #ifdef USE_5005THREADS
4673     dSP;
4674     EXTEND(SP, 1);
4675     if (PL_op->op_private & OPpLVAL_INTRO)
4676         PUSHs(*save_threadsv(PL_op->op_targ));
4677     else
4678         PUSHs(THREADSV(PL_op->op_targ));
4679     RETURN;
4680 #else
4681     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4682 #endif /* USE_5005THREADS */
4683 }