pp.c

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