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