pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 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 (count < 0)
1390         count = 0;
1391     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1392         dMARK;
1393         I32 items = SP - MARK;
1394         I32 max;
1395         static const char list_extend[] = "panic: list extend";
1396
1397         max = items * count;
1398         MEM_WRAP_CHECK_1(max, SV*, list_extend);
1399         if (items > 0 && max > 0 && (max < items || max < count))
1400            Perl_croak(aTHX_ list_extend);
1401         MEXTEND(MARK, max);
1402         if (count > 1) {
1403             while (SP > MARK) {
1404 #if 0
1405               /* This code was intended to fix 20010809.028:
1406
1407                  $x = 'abcd';
1408                  for (($x =~ /./g) x 2) {
1409                      print chop; # "abcdabcd" expected as output.
1410                  }
1411
1412                * but that change (#11635) broke this code:
1413
1414                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1415
1416                * I can't think of a better fix that doesn't introduce
1417                * an efficiency hit by copying the SVs. The stack isn't
1418                * refcounted, and mortalisation obviously doesn't
1419                * Do The Right Thing when the stack has more than
1420                * one pointer to the same mortal value.
1421                * .robin.
1422                */
1423                 if (*SP) {
1424                     *SP = sv_2mortal(newSVsv(*SP));
1425                     SvREADONLY_on(*SP);
1426                 }
1427 #else
1428                if (*SP)
1429                    SvTEMP_off((*SP));
1430 #endif
1431                 SP--;
1432             }
1433             MARK++;
1434             repeatcpy((char*)(MARK + items), (char*)MARK,
1435                 items * sizeof(SV*), count - 1);
1436             SP += max;
1437         }
1438         else if (count <= 0)
1439             SP -= items;
1440     }
1441     else {      /* Note: mark already snarfed by pp_list */
1442         SV *tmpstr = POPs;
1443         STRLEN len;
1444         bool isutf;
1445
1446         SvSetSV(TARG, tmpstr);
1447         SvPV_force(TARG, len);
1448         isutf = DO_UTF8(TARG);
1449         if (count != 1) {
1450             if (count < 1)
1451                 SvCUR_set(TARG, 0);
1452             else {
1453                 MEM_WRAP_CHECK_1(count, len, "panic: string extend");
1454                 SvGROW(TARG, (count * len) + 1);
1455                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1456                 SvCUR(TARG) *= count;
1457             }
1458             *SvEND(TARG) = '\0';
1459         }
1460         if (isutf)
1461             (void)SvPOK_only_UTF8(TARG);
1462         else
1463             (void)SvPOK_only(TARG);
1464
1465         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1466             /* The parser saw this as a list repeat, and there
1467                are probably several items on the stack. But we're
1468                in scalar context, and there's no pp_list to save us
1469                now. So drop the rest of the items -- robin@kitsite.com
1470              */
1471             dMARK;
1472             SP = MARK;
1473         }
1474         PUSHTARG;
1475     }
1476     RETURN;
1477   }
1478 }
1479
1480 PP(pp_subtract)
1481 {
1482     dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1483     useleft = USE_LEFT(TOPm1s);
1484 #ifdef PERL_PRESERVE_IVUV
1485     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1486        "bad things" happen if you rely on signed integers wrapping.  */
1487     SvIV_please(TOPs);
1488     if (SvIOK(TOPs)) {
1489         /* Unless the left argument is integer in range we are going to have to
1490            use NV maths. Hence only attempt to coerce the right argument if
1491            we know the left is integer.  */
1492         register UV auv = 0;
1493         bool auvok = FALSE;
1494         bool a_valid = 0;
1495
1496         if (!useleft) {
1497             auv = 0;
1498             a_valid = auvok = 1;
1499             /* left operand is undef, treat as zero.  */
1500         } else {
1501             /* Left operand is defined, so is it IV? */
1502             SvIV_please(TOPm1s);
1503             if (SvIOK(TOPm1s)) {
1504                 if ((auvok = SvUOK(TOPm1s)))
1505                     auv = SvUVX(TOPm1s);
1506                 else {
1507                     register IV aiv = SvIVX(TOPm1s);
1508                     if (aiv >= 0) {
1509                         auv = aiv;
1510                         auvok = 1;      /* Now acting as a sign flag.  */
1511                     } else { /* 2s complement assumption for IV_MIN */
1512                         auv = (UV)-aiv;
1513                     }
1514                 }
1515                 a_valid = 1;
1516             }
1517         }
1518         if (a_valid) {
1519             bool result_good = 0;
1520             UV result;
1521             register UV buv;
1522             bool buvok = SvUOK(TOPs);
1523
1524             if (buvok)
1525                 buv = SvUVX(TOPs);
1526             else {
1527                 register IV biv = SvIVX(TOPs);
1528                 if (biv >= 0) {
1529                     buv = biv;
1530                     buvok = 1;
1531                 } else
1532                     buv = (UV)-biv;
1533             }
1534             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1535                else "IV" now, independent of how it came in.
1536                if a, b represents positive, A, B negative, a maps to -A etc
1537                a - b =>  (a - b)
1538                A - b => -(a + b)
1539                a - B =>  (a + b)
1540                A - B => -(a - b)
1541                all UV maths. negate result if A negative.
1542                subtract if signs same, add if signs differ. */
1543
1544             if (auvok ^ buvok) {
1545                 /* Signs differ.  */
1546                 result = auv + buv;
1547                 if (result >= auv)
1548                     result_good = 1;
1549             } else {
1550                 /* Signs same */
1551                 if (auv >= buv) {
1552                     result = auv - buv;
1553                     /* Must get smaller */
1554                     if (result <= auv)
1555                         result_good = 1;
1556                 } else {
1557                     result = buv - auv;
1558                     if (result <= buv) {
1559                         /* result really should be -(auv-buv). as its negation
1560                            of true value, need to swap our result flag  */
1561                         auvok = !auvok;
1562                         result_good = 1;
1563                     }
1564                 }
1565             }
1566             if (result_good) {
1567                 SP--;
1568                 if (auvok)
1569                     SETu( result );
1570                 else {
1571                     /* Negate result */
1572                     if (result <= (UV)IV_MIN)
1573                         SETi( -(IV)result );
1574                     else {
1575                         /* result valid, but out of range for IV.  */
1576                         SETn( -(NV)result );
1577                     }
1578                 }
1579                 RETURN;
1580             } /* Overflow, drop through to NVs.  */
1581         }
1582     }
1583 #endif
1584     useleft = USE_LEFT(TOPm1s);
1585     {
1586         dPOPnv;
1587         if (!useleft) {
1588             /* left operand is undef, treat as zero - value */
1589             SETn(-value);
1590             RETURN;
1591         }
1592         SETn( TOPn - value );
1593         RETURN;
1594     }
1595 }
1596
1597 PP(pp_left_shift)
1598 {
1599     dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1600     {
1601       IV shift = POPi;
1602       if (PL_op->op_private & HINT_INTEGER) {
1603         IV i = TOPi;
1604         SETi(i << shift);
1605       }
1606       else {
1607         UV u = TOPu;
1608         SETu(u << shift);
1609       }
1610       RETURN;
1611     }
1612 }
1613
1614 PP(pp_right_shift)
1615 {
1616     dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1617     {
1618       IV shift = POPi;
1619       if (PL_op->op_private & HINT_INTEGER) {
1620         IV i = TOPi;
1621         SETi(i >> shift);
1622       }
1623       else {
1624         UV u = TOPu;
1625         SETu(u >> shift);
1626       }
1627       RETURN;
1628     }
1629 }
1630
1631 PP(pp_lt)
1632 {
1633     dSP; tryAMAGICbinSET(lt,0);
1634 #ifdef PERL_PRESERVE_IVUV
1635     SvIV_please(TOPs);
1636     if (SvIOK(TOPs)) {
1637         SvIV_please(TOPm1s);
1638         if (SvIOK(TOPm1s)) {
1639             bool auvok = SvUOK(TOPm1s);
1640             bool buvok = SvUOK(TOPs);
1641
1642             if (!auvok && !buvok) { /* ## IV < IV ## */
1643                 IV aiv = SvIVX(TOPm1s);
1644                 IV biv = SvIVX(TOPs);
1645
1646                 SP--;
1647                 SETs(boolSV(aiv < biv));
1648                 RETURN;
1649             }
1650             if (auvok && buvok) { /* ## UV < UV ## */
1651                 UV auv = SvUVX(TOPm1s);
1652                 UV buv = SvUVX(TOPs);
1653
1654                 SP--;
1655                 SETs(boolSV(auv < buv));
1656                 RETURN;
1657             }
1658             if (auvok) { /* ## UV < IV ## */
1659                 UV auv;
1660                 IV biv;
1661
1662                 biv = SvIVX(TOPs);
1663                 SP--;
1664                 if (biv < 0) {
1665                     /* As (a) is a UV, it's >=0, so it cannot be < */
1666                     SETs(&PL_sv_no);
1667                     RETURN;
1668                 }
1669                 auv = SvUVX(TOPs);
1670                 SETs(boolSV(auv < (UV)biv));
1671                 RETURN;
1672             }
1673             { /* ## IV < UV ## */
1674                 IV aiv;
1675                 UV buv;
1676
1677                 aiv = SvIVX(TOPm1s);
1678                 if (aiv < 0) {
1679                     /* As (b) is a UV, it's >=0, so it must be < */
1680                     SP--;
1681                     SETs(&PL_sv_yes);
1682                     RETURN;
1683                 }
1684                 buv = SvUVX(TOPs);
1685                 SP--;
1686                 SETs(boolSV((UV)aiv < buv));
1687                 RETURN;
1688             }
1689         }
1690     }
1691 #endif
1692 #ifndef NV_PRESERVES_UV
1693 #ifdef PERL_PRESERVE_IVUV
1694     else
1695 #endif
1696         if (SvROK(TOPs) && SvROK(TOPm1s)) {
1697             SP--;
1698             SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1699             RETURN;
1700         }
1701 #endif
1702     {
1703       dPOPnv;
1704       SETs(boolSV(TOPn < value));
1705       RETURN;
1706     }
1707 }
1708
1709 PP(pp_gt)
1710 {
1711     dSP; tryAMAGICbinSET(gt,0);
1712 #ifdef PERL_PRESERVE_IVUV
1713     SvIV_please(TOPs);
1714     if (SvIOK(TOPs)) {
1715         SvIV_please(TOPm1s);
1716         if (SvIOK(TOPm1s)) {
1717             bool auvok = SvUOK(TOPm1s);
1718             bool buvok = SvUOK(TOPs);
1719
1720             if (!auvok && !buvok) { /* ## IV > IV ## */
1721                 IV aiv = SvIVX(TOPm1s);
1722                 IV biv = SvIVX(TOPs);
1723
1724                 SP--;
1725                 SETs(boolSV(aiv > biv));
1726                 RETURN;
1727             }
1728             if (auvok && buvok) { /* ## UV > UV ## */
1729                 UV auv = SvUVX(TOPm1s);
1730                 UV buv = SvUVX(TOPs);
1731
1732                 SP--;
1733                 SETs(boolSV(auv > buv));
1734                 RETURN;
1735             }
1736             if (auvok) { /* ## UV > IV ## */
1737                 UV auv;
1738                 IV biv;
1739
1740                 biv = SvIVX(TOPs);
1741                 SP--;
1742                 if (biv < 0) {
1743                     /* As (a) is a UV, it's >=0, so it must be > */
1744                     SETs(&PL_sv_yes);
1745                     RETURN;
1746                 }
1747                 auv = SvUVX(TOPs);
1748                 SETs(boolSV(auv > (UV)biv));
1749                 RETURN;
1750             }
1751             { /* ## IV > UV ## */
1752                 IV aiv;
1753                 UV buv;
1754
1755                 aiv = SvIVX(TOPm1s);
1756                 if (aiv < 0) {
1757                     /* As (b) is a UV, it's >=0, so it cannot be > */
1758                     SP--;
1759                     SETs(&PL_sv_no);
1760                     RETURN;
1761                 }
1762                 buv = SvUVX(TOPs);
1763                 SP--;
1764                 SETs(boolSV((UV)aiv > buv));
1765                 RETURN;
1766             }
1767         }
1768     }
1769 #endif
1770 #ifndef NV_PRESERVES_UV
1771 #ifdef PERL_PRESERVE_IVUV
1772     else
1773 #endif
1774         if (SvROK(TOPs) && SvROK(TOPm1s)) {
1775         SP--;
1776         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1777         RETURN;
1778     }
1779 #endif
1780     {
1781       dPOPnv;
1782       SETs(boolSV(TOPn > value));
1783       RETURN;
1784     }
1785 }
1786
1787 PP(pp_le)
1788 {
1789     dSP; tryAMAGICbinSET(le,0);
1790 #ifdef PERL_PRESERVE_IVUV
1791     SvIV_please(TOPs);
1792     if (SvIOK(TOPs)) {
1793         SvIV_please(TOPm1s);
1794         if (SvIOK(TOPm1s)) {
1795             bool auvok = SvUOK(TOPm1s);
1796             bool buvok = SvUOK(TOPs);
1797
1798             if (!auvok && !buvok) { /* ## IV <= IV ## */
1799                 IV aiv = SvIVX(TOPm1s);
1800                 IV biv = SvIVX(TOPs);
1801
1802                 SP--;
1803                 SETs(boolSV(aiv <= biv));
1804                 RETURN;
1805             }
1806             if (auvok && buvok) { /* ## UV <= UV ## */
1807                 UV auv = SvUVX(TOPm1s);
1808                 UV buv = SvUVX(TOPs);
1809
1810                 SP--;
1811                 SETs(boolSV(auv <= buv));
1812                 RETURN;
1813             }
1814             if (auvok) { /* ## UV <= IV ## */
1815                 UV auv;
1816                 IV biv;
1817
1818                 biv = SvIVX(TOPs);
1819                 SP--;
1820                 if (biv < 0) {
1821                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1822                     SETs(&PL_sv_no);
1823                     RETURN;
1824                 }
1825                 auv = SvUVX(TOPs);
1826                 SETs(boolSV(auv <= (UV)biv));
1827                 RETURN;
1828             }
1829             { /* ## IV <= UV ## */
1830                 IV aiv;
1831                 UV buv;
1832
1833                 aiv = SvIVX(TOPm1s);
1834                 if (aiv < 0) {
1835                     /* As (b) is a UV, it's >=0, so a must be <= */
1836                     SP--;
1837                     SETs(&PL_sv_yes);
1838                     RETURN;
1839                 }
1840                 buv = SvUVX(TOPs);
1841                 SP--;
1842                 SETs(boolSV((UV)aiv <= buv));
1843                 RETURN;
1844             }
1845         }
1846     }
1847 #endif
1848 #ifndef NV_PRESERVES_UV
1849 #ifdef PERL_PRESERVE_IVUV
1850     else
1851 #endif
1852         if (SvROK(TOPs) && SvROK(TOPm1s)) {
1853         SP--;
1854         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1855         RETURN;
1856     }
1857 #endif
1858     {
1859       dPOPnv;
1860       SETs(boolSV(TOPn <= value));
1861       RETURN;
1862     }
1863 }
1864
1865 PP(pp_ge)
1866 {
1867     dSP; tryAMAGICbinSET(ge,0);
1868 #ifdef PERL_PRESERVE_IVUV
1869     SvIV_please(TOPs);
1870     if (SvIOK(TOPs)) {
1871         SvIV_please(TOPm1s);
1872         if (SvIOK(TOPm1s)) {
1873             bool auvok = SvUOK(TOPm1s);
1874             bool buvok = SvUOK(TOPs);
1875
1876             if (!auvok && !buvok) { /* ## IV >= IV ## */
1877                 IV aiv = SvIVX(TOPm1s);
1878                 IV biv = SvIVX(TOPs);
1879
1880                 SP--;
1881                 SETs(boolSV(aiv >= biv));
1882                 RETURN;
1883             }
1884             if (auvok && buvok) { /* ## UV >= UV ## */
1885                 UV auv = SvUVX(TOPm1s);
1886                 UV buv = SvUVX(TOPs);
1887
1888                 SP--;
1889                 SETs(boolSV(auv >= buv));
1890                 RETURN;
1891             }
1892             if (auvok) { /* ## UV >= IV ## */
1893                 UV auv;
1894                 IV biv;
1895
1896                 biv = SvIVX(TOPs);
1897                 SP--;
1898                 if (biv < 0) {
1899                     /* As (a) is a UV, it's >=0, so it must be >= */
1900                     SETs(&PL_sv_yes);
1901                     RETURN;
1902                 }
1903                 auv = SvUVX(TOPs);
1904                 SETs(boolSV(auv >= (UV)biv));
1905                 RETURN;
1906             }
1907             { /* ## IV >= UV ## */
1908                 IV aiv;
1909                 UV buv;
1910
1911                 aiv = SvIVX(TOPm1s);
1912                 if (aiv < 0) {
1913                     /* As (b) is a UV, it's >=0, so a cannot be >= */
1914                     SP--;
1915                     SETs(&PL_sv_no);
1916                     RETURN;
1917                 }
1918                 buv = SvUVX(TOPs);
1919                 SP--;
1920                 SETs(boolSV((UV)aiv >= buv));
1921                 RETURN;
1922             }
1923         }
1924     }
1925 #endif
1926 #ifndef NV_PRESERVES_UV
1927 #ifdef PERL_PRESERVE_IVUV
1928     else
1929 #endif
1930         if (SvROK(TOPs) && SvROK(TOPm1s)) {
1931         SP--;
1932         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1933         RETURN;
1934     }
1935 #endif
1936     {
1937       dPOPnv;
1938       SETs(boolSV(TOPn >= value));
1939       RETURN;
1940     }
1941 }
1942
1943 PP(pp_ne)
1944 {
1945     dSP; tryAMAGICbinSET(ne,0);
1946 #ifndef NV_PRESERVES_UV
1947     if (SvROK(TOPs) && SvROK(TOPm1s)) {
1948         SP--;
1949         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1950         RETURN;
1951     }
1952 #endif
1953 #ifdef PERL_PRESERVE_IVUV
1954     SvIV_please(TOPs);
1955     if (SvIOK(TOPs)) {
1956         SvIV_please(TOPm1s);
1957         if (SvIOK(TOPm1s)) {
1958             bool auvok = SvUOK(TOPm1s);
1959             bool buvok = SvUOK(TOPs);
1960
1961             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1962                 /* Casting IV to UV before comparison isn't going to matter
1963                    on 2s complement. On 1s complement or sign&magnitude
1964                    (if we have any of them) it could make negative zero
1965                    differ from normal zero. As I understand it. (Need to
1966                    check - is negative zero implementation defined behaviour
1967                    anyway?). NWC  */
1968                 UV buv = SvUVX(POPs);
1969                 UV auv = SvUVX(TOPs);
1970
1971                 SETs(boolSV(auv != buv));
1972                 RETURN;
1973             }
1974             {                   /* ## Mixed IV,UV ## */
1975                 IV iv;
1976                 UV uv;
1977
1978                 /* != is commutative so swap if needed (save code) */
1979                 if (auvok) {
1980                     /* swap. top of stack (b) is the iv */
1981                     iv = SvIVX(TOPs);
1982                     SP--;
1983                     if (iv < 0) {
1984                         /* As (a) is a UV, it's >0, so it cannot be == */
1985                         SETs(&PL_sv_yes);
1986                         RETURN;
1987                     }
1988                     uv = SvUVX(TOPs);
1989                 } else {
1990                     iv = SvIVX(TOPm1s);
1991                     SP--;
1992                     if (iv < 0) {
1993                         /* As (b) is a UV, it's >0, so it cannot be == */
1994                         SETs(&PL_sv_yes);
1995                         RETURN;
1996                     }
1997                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1998                 }
1999                 SETs(boolSV((UV)iv != uv));
2000                 RETURN;
2001             }
2002         }
2003     }
2004 #endif
2005     {
2006       dPOPnv;
2007       SETs(boolSV(TOPn != value));
2008       RETURN;
2009     }
2010 }
2011
2012 PP(pp_ncmp)
2013 {
2014     dSP; dTARGET; tryAMAGICbin(ncmp,0);
2015 #ifndef NV_PRESERVES_UV
2016     if (SvROK(TOPs) && SvROK(TOPm1s)) {
2017         UV right = PTR2UV(SvRV(POPs));
2018         UV left = PTR2UV(SvRV(TOPs));
2019         SETi((left > right) - (left < right));
2020         RETURN;
2021     }
2022 #endif
2023 #ifdef PERL_PRESERVE_IVUV
2024     /* Fortunately it seems NaN isn't IOK */
2025     SvIV_please(TOPs);
2026     if (SvIOK(TOPs)) {
2027         SvIV_please(TOPm1s);
2028         if (SvIOK(TOPm1s)) {
2029             bool leftuvok = SvUOK(TOPm1s);
2030             bool rightuvok = SvUOK(TOPs);
2031             I32 value;
2032             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2033                 IV leftiv = SvIVX(TOPm1s);
2034                 IV rightiv = SvIVX(TOPs);
2035
2036                 if (leftiv > rightiv)
2037                     value = 1;
2038                 else if (leftiv < rightiv)
2039                     value = -1;
2040                 else
2041                     value = 0;
2042             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2043                 UV leftuv = SvUVX(TOPm1s);
2044                 UV rightuv = SvUVX(TOPs);
2045
2046                 if (leftuv > rightuv)
2047                     value = 1;
2048                 else if (leftuv < rightuv)
2049                     value = -1;
2050                 else
2051                     value = 0;
2052             } else if (leftuvok) { /* ## UV <=> IV ## */
2053                 UV leftuv;
2054                 IV rightiv;
2055
2056                 rightiv = SvIVX(TOPs);
2057                 if (rightiv < 0) {
2058                     /* As (a) is a UV, it's >=0, so it cannot be < */
2059                     value = 1;
2060                 } else {
2061                     leftuv = SvUVX(TOPm1s);
2062                     if (leftuv > (UV)rightiv) {
2063                         value = 1;
2064                     } else if (leftuv < (UV)rightiv) {
2065                         value = -1;
2066                     } else {
2067                         value = 0;
2068                     }
2069                 }
2070             } else { /* ## IV <=> UV ## */
2071                 IV leftiv;
2072                 UV rightuv;
2073
2074                 leftiv = SvIVX(TOPm1s);
2075                 if (leftiv < 0) {
2076                     /* As (b) is a UV, it's >=0, so it must be < */
2077                     value = -1;
2078                 } else {
2079                     rightuv = SvUVX(TOPs);
2080                     if ((UV)leftiv > rightuv) {
2081                         value = 1;
2082                     } else if ((UV)leftiv < rightuv) {
2083                         value = -1;
2084                     } else {
2085                         value = 0;
2086                     }
2087                 }
2088             }
2089             SP--;
2090             SETi(value);
2091             RETURN;
2092         }
2093     }
2094 #endif
2095     {
2096       dPOPTOPnnrl;
2097       I32 value;
2098
2099 #ifdef Perl_isnan
2100       if (Perl_isnan(left) || Perl_isnan(right)) {
2101           SETs(&PL_sv_undef);
2102           RETURN;
2103        }
2104       value = (left > right) - (left < right);
2105 #else
2106       if (left == right)
2107         value = 0;
2108       else if (left < right)
2109         value = -1;
2110       else if (left > right)
2111         value = 1;
2112       else {
2113         SETs(&PL_sv_undef);
2114         RETURN;
2115       }
2116 #endif
2117       SETi(value);
2118       RETURN;
2119     }
2120 }
2121
2122 PP(pp_slt)
2123 {
2124     dSP; tryAMAGICbinSET(slt,0);
2125     {
2126       dPOPTOPssrl;
2127       int cmp = (IN_LOCALE_RUNTIME
2128                  ? sv_cmp_locale(left, right)
2129                  : sv_cmp(left, right));
2130       SETs(boolSV(cmp < 0));
2131       RETURN;
2132     }
2133 }
2134
2135 PP(pp_sgt)
2136 {
2137     dSP; tryAMAGICbinSET(sgt,0);
2138     {
2139       dPOPTOPssrl;
2140       int cmp = (IN_LOCALE_RUNTIME
2141                  ? sv_cmp_locale(left, right)
2142                  : sv_cmp(left, right));
2143       SETs(boolSV(cmp > 0));
2144       RETURN;
2145     }
2146 }
2147
2148 PP(pp_sle)
2149 {
2150     dSP; tryAMAGICbinSET(sle,0);
2151     {
2152       dPOPTOPssrl;
2153       int cmp = (IN_LOCALE_RUNTIME
2154                  ? sv_cmp_locale(left, right)
2155                  : sv_cmp(left, right));
2156       SETs(boolSV(cmp <= 0));
2157       RETURN;
2158     }
2159 }
2160
2161 PP(pp_sge)
2162 {
2163     dSP; tryAMAGICbinSET(sge,0);
2164     {
2165       dPOPTOPssrl;
2166       int cmp = (IN_LOCALE_RUNTIME
2167                  ? sv_cmp_locale(left, right)
2168                  : sv_cmp(left, right));
2169       SETs(boolSV(cmp >= 0));
2170       RETURN;
2171     }
2172 }
2173
2174 PP(pp_seq)
2175 {
2176     dSP; tryAMAGICbinSET(seq,0);
2177     {
2178       dPOPTOPssrl;
2179       SETs(boolSV(sv_eq(left, right)));
2180       RETURN;
2181     }
2182 }
2183
2184 PP(pp_sne)
2185 {
2186     dSP; tryAMAGICbinSET(sne,0);
2187     {
2188       dPOPTOPssrl;
2189       SETs(boolSV(!sv_eq(left, right)));
2190       RETURN;
2191     }
2192 }
2193
2194 PP(pp_scmp)
2195 {
2196     dSP; dTARGET;  tryAMAGICbin(scmp,0);
2197     {
2198       dPOPTOPssrl;
2199       int cmp = (IN_LOCALE_RUNTIME
2200                  ? sv_cmp_locale(left, right)
2201                  : sv_cmp(left, right));
2202       SETi( cmp );
2203       RETURN;
2204     }
2205 }
2206
2207 PP(pp_bit_and)
2208 {
2209     dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2210     {
2211       dPOPTOPssrl;
2212       if (SvGMAGICAL(left)) mg_get(left);
2213       if (SvGMAGICAL(right)) mg_get(right);
2214       if (SvNIOKp(left) || SvNIOKp(right)) {
2215         if (PL_op->op_private & HINT_INTEGER) {
2216           IV i = SvIV_nomg(left) & SvIV_nomg(right);
2217           SETi(i);
2218         }
2219         else {
2220           UV u = SvUV_nomg(left) & SvUV_nomg(right);
2221           SETu(u);
2222         }
2223       }
2224       else {
2225         do_vop(PL_op->op_type, TARG, left, right);
2226         SETTARG;
2227       }
2228       RETURN;
2229     }
2230 }
2231
2232 PP(pp_bit_xor)
2233 {
2234     dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2235     {
2236       dPOPTOPssrl;
2237       if (SvGMAGICAL(left)) mg_get(left);
2238       if (SvGMAGICAL(right)) mg_get(right);
2239       if (SvNIOKp(left) || SvNIOKp(right)) {
2240         if (PL_op->op_private & HINT_INTEGER) {
2241           IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2242           SETi(i);
2243         }
2244         else {
2245           UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2246           SETu(u);
2247         }
2248       }
2249       else {
2250         do_vop(PL_op->op_type, TARG, left, right);
2251         SETTARG;
2252       }
2253       RETURN;
2254     }
2255 }
2256
2257 PP(pp_bit_or)
2258 {
2259     dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2260     {
2261       dPOPTOPssrl;
2262       if (SvGMAGICAL(left)) mg_get(left);
2263       if (SvGMAGICAL(right)) mg_get(right);
2264       if (SvNIOKp(left) || SvNIOKp(right)) {
2265         if (PL_op->op_private & HINT_INTEGER) {
2266           IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2267           SETi(i);
2268         }
2269         else {
2270           UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2271           SETu(u);
2272         }
2273       }
2274       else {
2275         do_vop(PL_op->op_type, TARG, left, right);
2276         SETTARG;
2277       }
2278       RETURN;
2279     }
2280 }
2281
2282 PP(pp_negate)
2283 {
2284     dSP; dTARGET; tryAMAGICun(neg);
2285     {
2286         dTOPss;
2287         int flags = SvFLAGS(sv);
2288         if (SvGMAGICAL(sv))
2289             mg_get(sv);
2290         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2291             /* It's publicly an integer, or privately an integer-not-float */
2292         oops_its_an_int:
2293             if (SvIsUV(sv)) {
2294                 if (SvIVX(sv) == IV_MIN) {
2295                     /* 2s complement assumption. */
2296                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2297                     RETURN;
2298                 }
2299                 else if (SvUVX(sv) <= IV_MAX) {
2300                     SETi(-SvIVX(sv));
2301                     RETURN;
2302                 }
2303             }
2304             else if (SvIVX(sv) != IV_MIN) {
2305                 SETi(-SvIVX(sv));
2306                 RETURN;
2307             }
2308 #ifdef PERL_PRESERVE_IVUV
2309             else {
2310                 SETu((UV)IV_MIN);
2311                 RETURN;
2312             }
2313 #endif
2314         }
2315         if (SvNIOKp(sv))
2316             SETn(-SvNV(sv));
2317         else if (SvPOKp(sv)) {
2318             STRLEN len;
2319             char *s = SvPV(sv, len);
2320             if (isIDFIRST(*s)) {
2321                 sv_setpvn(TARG, "-", 1);
2322                 sv_catsv(TARG, sv);
2323             }
2324             else if (*s == '+' || *s == '-') {
2325                 sv_setsv(TARG, sv);
2326                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2327             }
2328             else if (DO_UTF8(sv)) {
2329                 SvIV_please(sv);
2330                 if (SvIOK(sv))
2331                     goto oops_its_an_int;
2332                 if (SvNOK(sv))
2333                     sv_setnv(TARG, -SvNV(sv));
2334                 else {
2335                     sv_setpvn(TARG, "-", 1);
2336                     sv_catsv(TARG, sv);
2337                 }
2338             }
2339             else {
2340                 SvIV_please(sv);
2341                 if (SvIOK(sv))
2342                   goto oops_its_an_int;
2343                 sv_setnv(TARG, -SvNV(sv));
2344             }
2345             SETTARG;
2346         }
2347         else
2348             SETn(-SvNV(sv));
2349     }
2350     RETURN;
2351 }
2352
2353 PP(pp_not)
2354 {
2355     dSP; tryAMAGICunSET(not);
2356     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2357     return NORMAL;
2358 }
2359
2360 PP(pp_complement)
2361 {
2362     dSP; dTARGET; tryAMAGICun(compl);
2363     {
2364       dTOPss;
2365       if (SvGMAGICAL(sv))
2366           mg_get(sv);
2367       if (SvNIOKp(sv)) {
2368         if (PL_op->op_private & HINT_INTEGER) {
2369           IV i = ~SvIV_nomg(sv);
2370           SETi(i);
2371         }
2372         else {
2373           UV u = ~SvUV_nomg(sv);
2374           SETu(u);
2375         }
2376       }
2377       else {
2378         register U8 *tmps;
2379         register I32 anum;
2380         STRLEN len;
2381
2382         (void)SvPV_nomg(sv,len); /* force check for uninit var */
2383         sv_setsv_nomg(TARG, sv);
2384         tmps = (U8*)SvPV_force(TARG, len);
2385         anum = len;
2386         if (SvUTF8(TARG)) {
2387           /* Calculate exact length, let's not estimate. */
2388           STRLEN targlen = 0;
2389           U8 *result;
2390           U8 *send;
2391           STRLEN l;
2392           UV nchar = 0;
2393           UV nwide = 0;
2394
2395           send = tmps + len;
2396           while (tmps < send) {
2397             UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2398             tmps += UTF8SKIP(tmps);
2399             targlen += UNISKIP(~c);
2400             nchar++;
2401             if (c > 0xff)
2402                 nwide++;
2403           }
2404
2405           /* Now rewind strings and write them. */
2406           tmps -= len;
2407
2408           if (nwide) {
2409               Newz(0, result, targlen + 1, U8);
2410               while (tmps < send) {
2411                   UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2412                   tmps += UTF8SKIP(tmps);
2413                   result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2414               }
2415               *result = '\0';
2416               result -= targlen;
2417               sv_setpvn(TARG, (char*)result, targlen);
2418               SvUTF8_on(TARG);
2419           }
2420           else {
2421               Newz(0, result, nchar + 1, U8);
2422               while (tmps < send) {
2423                   U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2424                   tmps += UTF8SKIP(tmps);
2425                   *result++ = ~c;
2426               }
2427               *result = '\0';
2428               result -= nchar;
2429               sv_setpvn(TARG, (char*)result, nchar);
2430               SvUTF8_off(TARG);
2431           }
2432           Safefree(result);
2433           SETs(TARG);
2434           RETURN;
2435         }
2436 #ifdef LIBERAL
2437         {
2438             register long *tmpl;
2439             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2440                 *tmps = ~*tmps;
2441             tmpl = (long*)tmps;
2442             for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2443                 *tmpl = ~*tmpl;
2444             tmps = (U8*)tmpl;
2445         }
2446 #endif
2447         for ( ; anum > 0; anum--, tmps++)
2448             *tmps = ~*tmps;
2449
2450         SETs(TARG);
2451       }
2452       RETURN;
2453     }
2454 }
2455
2456 /* integer versions of some of the above */
2457
2458 PP(pp_i_multiply)
2459 {
2460     dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2461     {
2462       dPOPTOPiirl;
2463       SETi( left * right );
2464       RETURN;
2465     }
2466 }
2467
2468 PP(pp_i_divide)
2469 {
2470     dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2471     {
2472       dPOPiv;
2473       if (value == 0)
2474         DIE(aTHX_ "Illegal division by zero");
2475       value = POPi / value;
2476       PUSHi( value );
2477       RETURN;
2478     }
2479 }
2480
2481 STATIC
2482 PP(pp_i_modulo_0)
2483 {
2484      /* This is the vanilla old i_modulo. */
2485      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2486      {
2487           dPOPTOPiirl;
2488           if (!right)
2489                DIE(aTHX_ "Illegal modulus zero");
2490           SETi( left % right );
2491           RETURN;
2492      }
2493 }
2494
2495 #if defined(__GLIBC__) && IVSIZE == 8
2496 STATIC
2497 PP(pp_i_modulo_1)
2498 {
2499      /* This is the i_modulo with the workaround for the _moddi3 bug
2500       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2501       * See below for pp_i_modulo. */
2502      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2503      {
2504           dPOPTOPiirl;
2505           if (!right)
2506                DIE(aTHX_ "Illegal modulus zero");
2507           SETi( left % PERL_ABS(right) );
2508           RETURN;
2509      }
2510 }
2511 #endif
2512
2513 PP(pp_i_modulo)
2514 {
2515      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2516      {
2517           dPOPTOPiirl;
2518           if (!right)
2519                DIE(aTHX_ "Illegal modulus zero");
2520           /* The assumption is to use hereafter the old vanilla version... */
2521           PL_op->op_ppaddr =
2522                PL_ppaddr[OP_I_MODULO] =
2523                    &Perl_pp_i_modulo_0;
2524           /* .. but if we have glibc, we might have a buggy _moddi3
2525            * (at least glicb 2.2.5 is known to have this bug), in other
2526            * words our integer modulus with negative quad as the second
2527            * argument might be broken.  Test for this and re-patch the
2528            * opcode dispatch table if that is the case, remembering to
2529            * also apply the workaround so that this first round works
2530            * right, too.  See [perl #9402] for more information. */
2531 #if defined(__GLIBC__) && IVSIZE == 8
2532           {
2533                IV l =   3;
2534                IV r = -10;
2535                /* Cannot do this check with inlined IV constants since
2536                 * that seems to work correctly even with the buggy glibc. */
2537                if (l % r == -3) {
2538                     /* Yikes, we have the bug.
2539                      * Patch in the workaround version. */
2540                     PL_op->op_ppaddr =
2541                          PL_ppaddr[OP_I_MODULO] =
2542                              &Perl_pp_i_modulo_1;
2543                     /* Make certain we work right this time, too. */
2544                     right = PERL_ABS(right);
2545                }
2546           }
2547 #endif
2548           SETi( left % right );
2549           RETURN;
2550      }
2551 }
2552
2553 PP(pp_i_add)
2554 {
2555     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2556     {
2557       dPOPTOPiirl_ul;
2558       SETi( left + right );
2559       RETURN;
2560     }
2561 }
2562
2563 PP(pp_i_subtract)
2564 {
2565     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2566     {
2567       dPOPTOPiirl_ul;
2568       SETi( left - right );
2569       RETURN;
2570     }
2571 }
2572
2573 PP(pp_i_lt)
2574 {
2575     dSP; tryAMAGICbinSET(lt,0);
2576     {
2577       dPOPTOPiirl;
2578       SETs(boolSV(left < right));
2579       RETURN;
2580     }
2581 }
2582
2583 PP(pp_i_gt)
2584 {
2585     dSP; tryAMAGICbinSET(gt,0);
2586     {
2587       dPOPTOPiirl;
2588       SETs(boolSV(left > right));
2589       RETURN;
2590     }
2591 }
2592
2593 PP(pp_i_le)
2594 {
2595     dSP; tryAMAGICbinSET(le,0);
2596     {
2597       dPOPTOPiirl;
2598       SETs(boolSV(left <= right));
2599       RETURN;
2600     }
2601 }
2602
2603 PP(pp_i_ge)
2604 {
2605     dSP; tryAMAGICbinSET(ge,0);
2606     {
2607       dPOPTOPiirl;
2608       SETs(boolSV(left >= right));
2609       RETURN;
2610     }
2611 }
2612
2613 PP(pp_i_eq)
2614 {
2615     dSP; tryAMAGICbinSET(eq,0);
2616     {
2617       dPOPTOPiirl;
2618       SETs(boolSV(left == right));
2619       RETURN;
2620     }
2621 }
2622
2623 PP(pp_i_ne)
2624 {
2625     dSP; tryAMAGICbinSET(ne,0);
2626     {
2627       dPOPTOPiirl;
2628       SETs(boolSV(left != right));
2629       RETURN;
2630     }
2631 }
2632
2633 PP(pp_i_ncmp)
2634 {
2635     dSP; dTARGET; tryAMAGICbin(ncmp,0);
2636     {
2637       dPOPTOPiirl;
2638       I32 value;
2639
2640       if (left > right)
2641         value = 1;
2642       else if (left < right)
2643         value = -1;
2644       else
2645         value = 0;
2646       SETi(value);
2647       RETURN;
2648     }
2649 }
2650
2651 PP(pp_i_negate)
2652 {
2653     dSP; dTARGET; tryAMAGICun(neg);
2654     SETi(-TOPi);
2655     RETURN;
2656 }
2657
2658 /* High falutin' math. */
2659
2660 PP(pp_atan2)
2661 {
2662     dSP; dTARGET; tryAMAGICbin(atan2,0);
2663     {
2664       dPOPTOPnnrl;
2665       SETn(Perl_atan2(left, right));
2666       RETURN;
2667     }
2668 }
2669
2670 PP(pp_sin)
2671 {
2672     dSP; dTARGET; tryAMAGICun(sin);
2673     {
2674       NV value;
2675       value = POPn;
2676       value = Perl_sin(value);
2677       XPUSHn(value);
2678       RETURN;
2679     }
2680 }
2681
2682 PP(pp_cos)
2683 {
2684     dSP; dTARGET; tryAMAGICun(cos);
2685     {
2686       NV value;
2687       value = POPn;
2688       value = Perl_cos(value);
2689       XPUSHn(value);
2690       RETURN;
2691     }
2692 }
2693
2694 /* Support Configure command-line overrides for rand() functions.
2695    After 5.005, perhaps we should replace this by Configure support
2696    for drand48(), random(), or rand().  For 5.005, though, maintain
2697    compatibility by calling rand() but allow the user to override it.
2698    See INSTALL for details.  --Andy Dougherty  15 July 1998
2699 */
2700 /* Now it's after 5.005, and Configure supports drand48() and random(),
2701    in addition to rand().  So the overrides should not be needed any more.
2702    --Jarkko Hietaniemi  27 September 1998
2703  */
2704
2705 #ifndef HAS_DRAND48_PROTO
2706 extern double drand48 (void);
2707 #endif
2708
2709 PP(pp_rand)
2710 {
2711     dSP; dTARGET;
2712     NV value;
2713     if (MAXARG < 1)
2714         value = 1.0;
2715     else
2716         value = POPn;
2717     if (value == 0.0)
2718         value = 1.0;
2719     if (!PL_srand_called) {
2720         (void)seedDrand01((Rand_seed_t)seed());
2721         PL_srand_called = TRUE;
2722     }
2723     value *= Drand01();
2724     XPUSHn(value);
2725     RETURN;
2726 }
2727
2728 PP(pp_srand)
2729 {
2730     dSP;
2731     UV anum;
2732     if (MAXARG < 1)
2733         anum = seed();
2734     else
2735         anum = POPu;
2736     (void)seedDrand01((Rand_seed_t)anum);
2737     PL_srand_called = TRUE;
2738     EXTEND(SP, 1);
2739     RETPUSHYES;
2740 }
2741
2742 PP(pp_exp)
2743 {
2744     dSP; dTARGET; tryAMAGICun(exp);
2745     {
2746       NV value;
2747       value = POPn;
2748       value = Perl_exp(value);
2749       XPUSHn(value);
2750       RETURN;
2751     }
2752 }
2753
2754 PP(pp_log)
2755 {
2756     dSP; dTARGET; tryAMAGICun(log);
2757     {
2758       NV value;
2759       value = POPn;
2760       if (value <= 0.0) {
2761         SET_NUMERIC_STANDARD();
2762         DIE(aTHX_ "Can't take log of %"NVgf, value);
2763       }
2764       value = Perl_log(value);
2765       XPUSHn(value);
2766       RETURN;
2767     }
2768 }
2769
2770 PP(pp_sqrt)
2771 {
2772     dSP; dTARGET; tryAMAGICun(sqrt);
2773     {
2774       NV value;
2775       value = POPn;
2776       if (value < 0.0) {
2777         SET_NUMERIC_STANDARD();
2778         DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2779       }
2780       value = Perl_sqrt(value);
2781       XPUSHn(value);
2782       RETURN;
2783     }
2784 }
2785
2786 PP(pp_int)
2787 {
2788     dSP; dTARGET; tryAMAGICun(int);
2789     {
2790       NV value;
2791       IV iv = TOPi; /* attempt to convert to IV if possible. */
2792       /* XXX it's arguable that compiler casting to IV might be subtly
2793          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2794          else preferring IV has introduced a subtle behaviour change bug. OTOH
2795          relying on floating point to be accurate is a bug.  */
2796
2797       if (SvIOK(TOPs)) {
2798         if (SvIsUV(TOPs)) {
2799             UV uv = TOPu;
2800             SETu(uv);
2801         } else
2802             SETi(iv);
2803       } else {
2804           value = TOPn;
2805           if (value >= 0.0) {
2806               if (value < (NV)UV_MAX + 0.5) {
2807                   SETu(U_V(value));
2808               } else {
2809                   SETn(Perl_floor(value));
2810               }
2811           }
2812           else {
2813               if (value > (NV)IV_MIN - 0.5) {
2814                   SETi(I_V(value));
2815               } else {
2816                   SETn(Perl_ceil(value));
2817               }
2818           }
2819       }
2820     }
2821     RETURN;
2822 }
2823
2824 PP(pp_abs)
2825 {
2826     dSP; dTARGET; tryAMAGICun(abs);
2827     {
2828       /* This will cache the NV value if string isn't actually integer  */
2829       IV iv = TOPi;
2830
2831       if (SvIOK(TOPs)) {
2832         /* IVX is precise  */
2833         if (SvIsUV(TOPs)) {
2834           SETu(TOPu);   /* force it to be numeric only */
2835         } else {
2836           if (iv >= 0) {
2837             SETi(iv);
2838           } else {
2839             if (iv != IV_MIN) {
2840               SETi(-iv);
2841             } else {
2842               /* 2s complement assumption. Also, not really needed as
2843                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2844               SETu(IV_MIN);
2845             }
2846           }
2847         }
2848       } else{
2849         NV value = TOPn;
2850         if (value < 0.0)
2851           value = -value;
2852         SETn(value);
2853       }
2854     }
2855     RETURN;
2856 }
2857
2858
2859 PP(pp_hex)
2860 {
2861     dSP; dTARGET;
2862     char *tmps;
2863     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2864     STRLEN len;
2865     NV result_nv;
2866     UV result_uv;
2867     SV* sv = POPs;
2868
2869     tmps = (SvPVx(sv, len));
2870     if (DO_UTF8(sv)) {
2871          /* If Unicode, try to downgrade
2872           * If not possible, croak. */
2873          SV* tsv = sv_2mortal(newSVsv(sv));
2874
2875          SvUTF8_on(tsv);
2876          sv_utf8_downgrade(tsv, FALSE);
2877          tmps = SvPVX(tsv);
2878     }
2879     result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2880     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2881         XPUSHn(result_nv);
2882     }
2883     else {
2884         XPUSHu(result_uv);
2885     }
2886     RETURN;
2887 }
2888
2889 PP(pp_oct)
2890 {
2891     dSP; dTARGET;
2892     char *tmps;
2893     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2894     STRLEN len;
2895     NV result_nv;
2896     UV result_uv;
2897     SV* sv = POPs;
2898
2899     tmps = (SvPVx(sv, len));
2900     if (DO_UTF8(sv)) {
2901          /* If Unicode, try to downgrade
2902           * If not possible, croak. */
2903          SV* tsv = sv_2mortal(newSVsv(sv));
2904
2905          SvUTF8_on(tsv);
2906          sv_utf8_downgrade(tsv, FALSE);
2907          tmps = SvPVX(tsv);
2908     }
2909     while (*tmps && len && isSPACE(*tmps))
2910         tmps++, len--;
2911     if (*tmps == '0')
2912         tmps++, len--;
2913     if (*tmps == 'x')
2914         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2915     else if (*tmps == 'b')
2916         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2917     else
2918         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2919
2920     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2921         XPUSHn(result_nv);
2922     }
2923     else {
2924         XPUSHu(result_uv);
2925     }
2926     RETURN;
2927 }
2928
2929 /* String stuff. */
2930
2931 PP(pp_length)
2932 {
2933     dSP; dTARGET;
2934     SV *sv = TOPs;
2935
2936     if (DO_UTF8(sv))
2937         SETi(sv_len_utf8(sv));
2938     else
2939         SETi(sv_len(sv));
2940     RETURN;
2941 }
2942
2943 PP(pp_substr)
2944 {
2945     dSP; dTARGET;
2946     SV *sv;
2947     I32 len = 0;
2948     STRLEN curlen;
2949     STRLEN utf8_curlen;
2950     I32 pos;
2951     I32 rem;
2952     I32 fail;
2953     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2954     char *tmps;
2955     I32 arybase = PL_curcop->cop_arybase;
2956     SV *repl_sv = NULL;
2957     char *repl = 0;
2958     STRLEN repl_len;
2959     int num_args = PL_op->op_private & 7;
2960     bool repl_need_utf8_upgrade = FALSE;
2961     bool repl_is_utf8 = FALSE;
2962
2963     SvTAINTED_off(TARG);                        /* decontaminate */
2964     SvUTF8_off(TARG);                           /* decontaminate */
2965     if (num_args > 2) {
2966         if (num_args > 3) {
2967             repl_sv = POPs;
2968             repl = SvPV(repl_sv, repl_len);
2969             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2970         }
2971         len = POPi;
2972     }
2973     pos = POPi;
2974     sv = POPs;
2975     PUTBACK;
2976     if (repl_sv) {
2977         if (repl_is_utf8) {
2978             if (!DO_UTF8(sv))
2979                 sv_utf8_upgrade(sv);
2980         }
2981         else if (DO_UTF8(sv))
2982             repl_need_utf8_upgrade = TRUE;
2983     }
2984     tmps = SvPV(sv, curlen);
2985     if (DO_UTF8(sv)) {
2986         utf8_curlen = sv_len_utf8(sv);
2987         if (utf8_curlen == curlen)
2988             utf8_curlen = 0;
2989         else
2990             curlen = utf8_curlen;
2991     }
2992     else
2993         utf8_curlen = 0;
2994
2995     if (pos >= arybase) {
2996         pos -= arybase;
2997         rem = curlen-pos;
2998         fail = rem;
2999         if (num_args > 2) {
3000             if (len < 0) {
3001                 rem += len;
3002                 if (rem < 0)
3003                     rem = 0;
3004             }
3005             else if (rem > len)
3006                      rem = len;
3007         }
3008     }
3009     else {
3010         pos += curlen;
3011         if (num_args < 3)
3012             rem = curlen;
3013         else if (len >= 0) {
3014             rem = pos+len;
3015             if (rem > (I32)curlen)
3016                 rem = curlen;
3017         }
3018         else {
3019             rem = curlen+len;
3020             if (rem < pos)
3021                 rem = pos;
3022         }
3023         if (pos < 0)
3024             pos = 0;
3025         fail = rem;
3026         rem -= pos;
3027     }
3028     if (fail < 0) {
3029         if (lvalue || repl)
3030             Perl_croak(aTHX_ "substr outside of string");
3031         if (ckWARN(WARN_SUBSTR))
3032             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3033         RETPUSHUNDEF;
3034     }
3035     else {
3036         I32 upos = pos;
3037         I32 urem = rem;
3038         if (utf8_curlen)
3039             sv_pos_u2b(sv, &pos, &rem);
3040         tmps += pos;
3041         /* we either return a PV or an LV. If the TARG hasn't been used
3042          * before, or is of that type, reuse it; otherwise use a mortal
3043          * instead. Note that LVs can have an extended lifetime, so also
3044          * dont reuse if refcount > 1 (bug #20933) */
3045         if (SvTYPE(TARG) > SVt_NULL) {
3046             if ( (SvTYPE(TARG) == SVt_PVLV)
3047                     ? (!lvalue || SvREFCNT(TARG) > 1)
3048                     : lvalue)
3049             {
3050                 TARG = sv_newmortal();
3051             }
3052         }
3053
3054         sv_setpvn(TARG, tmps, rem);
3055 #ifdef USE_LOCALE_COLLATE
3056         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3057 #endif
3058         if (utf8_curlen)
3059             SvUTF8_on(TARG);
3060         if (repl) {
3061             SV* repl_sv_copy = NULL;
3062
3063             if (repl_need_utf8_upgrade) {
3064                 repl_sv_copy = newSVsv(repl_sv);
3065                 sv_utf8_upgrade(repl_sv_copy);
3066                 repl = SvPV(repl_sv_copy, repl_len);
3067                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3068             }
3069             sv_insert(sv, pos, rem, repl, repl_len);
3070             if (repl_is_utf8)
3071                 SvUTF8_on(sv);
3072             if (repl_sv_copy)
3073                 SvREFCNT_dec(repl_sv_copy);
3074         }
3075         else if (lvalue) {              /* it's an lvalue! */
3076             if (!SvGMAGICAL(sv)) {
3077                 if (SvROK(sv)) {
3078                     STRLEN n_a;
3079                     SvPV_force(sv,n_a);
3080                     if (ckWARN(WARN_SUBSTR))
3081                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3082                                 "Attempt to use reference as lvalue in substr");
3083                 }
3084                 if (SvOK(sv))           /* is it defined ? */
3085                     (void)SvPOK_only_UTF8(sv);
3086                 else
3087                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3088             }
3089
3090             if (SvTYPE(TARG) < SVt_PVLV) {
3091                 sv_upgrade(TARG, SVt_PVLV);
3092                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3093             }
3094             else
3095                 (void)SvOK_off(TARG);
3096
3097             LvTYPE(TARG) = 'x';
3098             if (LvTARG(TARG) != sv) {
3099                 if (LvTARG(TARG))
3100                     SvREFCNT_dec(LvTARG(TARG));
3101                 LvTARG(TARG) = SvREFCNT_inc(sv);
3102             }
3103             LvTARGOFF(TARG) = upos;
3104             LvTARGLEN(TARG) = urem;
3105         }
3106     }
3107     SPAGAIN;
3108     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3109     RETURN;
3110 }
3111
3112 PP(pp_vec)
3113 {
3114     dSP; dTARGET;
3115     register IV size   = POPi;
3116     register IV offset = POPi;
3117     register SV *src = POPs;
3118     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3119
3120     SvTAINTED_off(TARG);                /* decontaminate */
3121     if (lvalue) {                       /* it's an lvalue! */
3122         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3123             TARG = sv_newmortal();
3124         if (SvTYPE(TARG) < SVt_PVLV) {
3125             sv_upgrade(TARG, SVt_PVLV);
3126             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3127         }
3128         LvTYPE(TARG) = 'v';
3129         if (LvTARG(TARG) != src) {
3130             if (LvTARG(TARG))
3131                 SvREFCNT_dec(LvTARG(TARG));
3132             LvTARG(TARG) = SvREFCNT_inc(src);
3133         }
3134         LvTARGOFF(TARG) = offset;
3135         LvTARGLEN(TARG) = size;
3136     }
3137
3138     sv_setuv(TARG, do_vecget(src, offset, size));
3139     PUSHs(TARG);
3140     RETURN;
3141 }
3142
3143 PP(pp_index)
3144 {
3145     dSP; dTARGET;
3146     SV *big;
3147     SV *little;
3148     I32 offset;
3149     I32 retval;
3150     char *tmps;
3151     char *tmps2;
3152     STRLEN biglen;
3153     I32 arybase = PL_curcop->cop_arybase;
3154
3155     if (MAXARG < 3)
3156         offset = 0;
3157     else
3158         offset = POPi - arybase;
3159     little = POPs;
3160     big = POPs;
3161     tmps = SvPV(big, biglen);
3162     if (offset > 0 && DO_UTF8(big))
3163         sv_pos_u2b(big, &offset, 0);
3164     if (offset < 0)
3165         offset = 0;
3166     else if (offset > (I32)biglen)
3167         offset = biglen;
3168     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3169       (unsigned char*)tmps + biglen, little, 0)))
3170         retval = -1;
3171     else
3172         retval = tmps2 - tmps;
3173     if (retval > 0 && DO_UTF8(big))
3174         sv_pos_b2u(big, &retval);
3175     PUSHi(retval + arybase);
3176     RETURN;
3177 }
3178
3179 PP(pp_rindex)
3180 {
3181     dSP; dTARGET;
3182     SV *big;
3183     SV *little;
3184     STRLEN blen;
3185     STRLEN llen;
3186     I32 offset;
3187     I32 retval;
3188     char *tmps;
3189     char *tmps2;
3190     I32 arybase = PL_curcop->cop_arybase;
3191
3192     if (MAXARG >= 3)
3193         offset = POPi;
3194     little = POPs;
3195     big = POPs;
3196     tmps2 = SvPV(little, llen);
3197     tmps = SvPV(big, blen);
3198     if (MAXARG < 3)
3199         offset = blen;
3200     else {
3201         if (offset > 0 && DO_UTF8(big))
3202             sv_pos_u2b(big, &offset, 0);
3203         offset = offset - arybase + llen;
3204     }
3205     if (offset < 0)
3206         offset = 0;
3207     else if (offset > (I32)blen)
3208         offset = blen;
3209     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3210                           tmps2, tmps2 + llen)))
3211         retval = -1;
3212     else
3213         retval = tmps2 - tmps;
3214     if (retval > 0 && DO_UTF8(big))
3215         sv_pos_b2u(big, &retval);
3216     PUSHi(retval + arybase);
3217     RETURN;
3218 }
3219
3220 PP(pp_sprintf)
3221 {
3222     dSP; dMARK; dORIGMARK; dTARGET;
3223     do_sprintf(TARG, SP-MARK, MARK+1);
3224     TAINT_IF(SvTAINTED(TARG));
3225     if (DO_UTF8(*(MARK+1)))
3226         SvUTF8_on(TARG);
3227     SP = ORIGMARK;
3228     PUSHTARG;
3229     RETURN;
3230 }
3231
3232 PP(pp_ord)
3233 {
3234     dSP; dTARGET;
3235     SV *argsv = POPs;
3236     STRLEN len;
3237     U8 *s = (U8*)SvPVx(argsv, len);
3238     SV *tmpsv;
3239
3240     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3241         tmpsv = sv_2mortal(newSVsv(argsv));
3242         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3243         argsv = tmpsv;
3244     }
3245
3246     XPUSHu(DO_UTF8(argsv) ?
3247            utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3248            (*s & 0xff));
3249
3250     RETURN;
3251 }
3252
3253 PP(pp_chr)
3254 {
3255     dSP; dTARGET;
3256     char *tmps;
3257     UV value = POPu;
3258
3259     (void)SvUPGRADE(TARG,SVt_PV);
3260
3261     if (value > 255 && !IN_BYTES) {
3262         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3263         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3264         SvCUR_set(TARG, tmps - SvPVX(TARG));
3265         *tmps = '\0';
3266         (void)SvPOK_only(TARG);
3267         SvUTF8_on(TARG);
3268         XPUSHs(TARG);
3269         RETURN;
3270     }
3271
3272     SvGROW(TARG,2);
3273     SvCUR_set(TARG, 1);
3274     tmps = SvPVX(TARG);
3275     *tmps++ = (char)value;
3276     *tmps = '\0';
3277     (void)SvPOK_only(TARG);
3278     if (PL_encoding && !IN_BYTES) {
3279         sv_recode_to_utf8(TARG, PL_encoding);
3280         tmps = SvPVX(TARG);
3281         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3282             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3283             SvGROW(TARG, 3);
3284             tmps = SvPVX(TARG);
3285             SvCUR_set(TARG, 2);
3286             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3287             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3288             *tmps = '\0';
3289             SvUTF8_on(TARG);
3290         }
3291     }
3292     XPUSHs(TARG);
3293     RETURN;
3294 }
3295
3296 PP(pp_crypt)
3297 {
3298     dSP; dTARGET;
3299 #ifdef HAS_CRYPT
3300     dPOPTOPssrl;
3301     STRLEN n_a;
3302     STRLEN len;
3303     char *tmps = SvPV(left, len);
3304
3305     if (DO_UTF8(left)) {
3306          /* If Unicode, try to downgrade.
3307           * If not possible, croak.
3308           * Yes, we made this up.  */
3309          SV* tsv = sv_2mortal(newSVsv(left));
3310
3311          SvUTF8_on(tsv);
3312          sv_utf8_downgrade(tsv, FALSE);
3313          tmps = SvPVX(tsv);
3314     }
3315 #   ifdef USE_ITHREADS
3316 #     ifdef HAS_CRYPT_R
3317     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3318       /* This should be threadsafe because in ithreads there is only
3319        * one thread per interpreter.  If this would not be true,
3320        * we would need a mutex to protect this malloc. */
3321         PL_reentrant_buffer->_crypt_struct_buffer =
3322           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3323 #if defined(__GLIBC__) || defined(__EMX__)
3324         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3325             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3326             /* work around glibc-2.2.5 bug */
3327             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3328         }
3329 #endif
3330     }
3331 #     endif /* HAS_CRYPT_R */
3332 #   endif /* USE_ITHREADS */
3333 #   ifdef FCRYPT
3334     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3335 #   else
3336     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3337 #   endif
3338     SETs(TARG);
3339     RETURN;
3340 #else
3341     DIE(aTHX_
3342       "The crypt() function is unimplemented due to excessive paranoia.");
3343 #endif
3344 }
3345
3346 PP(pp_ucfirst)
3347 {
3348     dSP;
3349     SV *sv = TOPs;
3350     register U8 *s;
3351     STRLEN slen;
3352
3353     SvGETMAGIC(sv);
3354     if (DO_UTF8(sv) &&
3355         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3356         UTF8_IS_START(*s)) {
3357         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3358         STRLEN ulen;
3359         STRLEN tculen;
3360
3361         utf8_to_uvchr(s, &ulen);
3362         toTITLE_utf8(s, tmpbuf, &tculen);
3363         utf8_to_uvchr(tmpbuf, 0);
3364
3365         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3366             dTARGET;
3367             /* slen is the byte length of the whole SV.
3368              * ulen is the byte length of the original Unicode character
3369              * stored as UTF-8 at s.
3370              * tculen is the byte length of the freshly titlecased
3371              * Unicode character stored as UTF-8 at tmpbuf.
3372              * We first set the result to be the titlecased character,
3373              * and then append the rest of the SV data. */
3374             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3375             if (slen > ulen)
3376                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3377             SvUTF8_on(TARG);
3378             SETs(TARG);
3379         }
3380         else {
3381             s = (U8*)SvPV_force_nomg(sv, slen);
3382             Copy(tmpbuf, s, tculen, U8);
3383         }
3384     }
3385     else {
3386         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3387             dTARGET;
3388             SvUTF8_off(TARG);                           /* decontaminate */
3389             sv_setsv_nomg(TARG, sv);
3390             sv = TARG;
3391             SETs(sv);
3392         }
3393         s = (U8*)SvPV_force_nomg(sv, slen);
3394         if (*s) {
3395             if (IN_LOCALE_RUNTIME) {
3396                 TAINT;
3397                 SvTAINTED_on(sv);
3398                 *s = toUPPER_LC(*s);
3399             }
3400             else
3401                 *s = toUPPER(*s);
3402         }
3403     }
3404     SvSETMAGIC(sv);
3405     RETURN;
3406 }
3407
3408 PP(pp_lcfirst)
3409 {
3410     dSP;
3411     SV *sv = TOPs;
3412     register U8 *s;
3413     STRLEN slen;
3414
3415     SvGETMAGIC(sv);
3416     if (DO_UTF8(sv) &&
3417         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3418         UTF8_IS_START(*s)) {
3419         STRLEN ulen;
3420         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3421         U8 *tend;
3422         UV uv;
3423
3424         toLOWER_utf8(s, tmpbuf, &ulen);
3425         uv = utf8_to_uvchr(tmpbuf, 0);
3426         tend = uvchr_to_utf8(tmpbuf, uv);
3427
3428         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3429             dTARGET;
3430             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3431             if (slen > ulen)
3432                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3433             SvUTF8_on(TARG);
3434             SETs(TARG);
3435         }
3436         else {
3437             s = (U8*)SvPV_force_nomg(sv, slen);
3438             Copy(tmpbuf, s, ulen, U8);
3439         }
3440     }
3441     else {
3442         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3443             dTARGET;
3444             SvUTF8_off(TARG);                           /* decontaminate */
3445             sv_setsv_nomg(TARG, sv);
3446             sv = TARG;
3447             SETs(sv);
3448         }
3449         s = (U8*)SvPV_force_nomg(sv, slen);
3450         if (*s) {
3451             if (IN_LOCALE_RUNTIME) {
3452                 TAINT;
3453                 SvTAINTED_on(sv);
3454                 *s = toLOWER_LC(*s);
3455             }
3456             else
3457                 *s = toLOWER(*s);
3458         }
3459     }
3460     SvSETMAGIC(sv);
3461     RETURN;
3462 }
3463
3464 PP(pp_uc)
3465 {
3466     dSP;
3467     SV *sv = TOPs;
3468     register U8 *s;
3469     STRLEN len;
3470
3471     SvGETMAGIC(sv);
3472     if (DO_UTF8(sv)) {
3473         dTARGET;
3474         STRLEN ulen;
3475         register U8 *d;
3476         U8 *send;
3477         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3478
3479         s = (U8*)SvPV_nomg(sv,len);
3480         if (!len) {
3481             SvUTF8_off(TARG);                           /* decontaminate */
3482             sv_setpvn(TARG, "", 0);
3483             SETs(TARG);
3484         }
3485         else {
3486             STRLEN nchar = utf8_length(s, s + len);
3487
3488             (void)SvUPGRADE(TARG, SVt_PV);
3489             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3490             (void)SvPOK_only(TARG);
3491             d = (U8*)SvPVX(TARG);
3492             send = s + len;
3493             while (s < send) {
3494                 toUPPER_utf8(s, tmpbuf, &ulen);
3495                 Copy(tmpbuf, d, ulen, U8);
3496                 d += ulen;
3497                 s += UTF8SKIP(s);
3498             }
3499             *d = '\0';
3500             SvUTF8_on(TARG);
3501             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3502             SETs(TARG);
3503         }
3504     }
3505     else {
3506         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3507             dTARGET;
3508             SvUTF8_off(TARG);                           /* decontaminate */
3509             sv_setsv_nomg(TARG, sv);
3510             sv = TARG;
3511             SETs(sv);
3512         }
3513         s = (U8*)SvPV_force_nomg(sv, len);
3514         if (len) {
3515             register U8 *send = s + len;
3516
3517             if (IN_LOCALE_RUNTIME) {
3518                 TAINT;
3519                 SvTAINTED_on(sv);
3520                 for (; s < send; s++)
3521                     *s = toUPPER_LC(*s);
3522             }
3523             else {
3524                 for (; s < send; s++)
3525                     *s = toUPPER(*s);
3526             }
3527         }
3528     }
3529     SvSETMAGIC(sv);
3530     RETURN;
3531 }
3532
3533 PP(pp_lc)
3534 {
3535     dSP;
3536     SV *sv = TOPs;
3537     register U8 *s;
3538     STRLEN len;
3539
3540     SvGETMAGIC(sv);
3541     if (DO_UTF8(sv)) {
3542         dTARGET;
3543         STRLEN ulen;
3544         register U8 *d;
3545         U8 *send;
3546         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3547
3548         s = (U8*)SvPV_nomg(sv,len);
3549         if (!len) {
3550             SvUTF8_off(TARG);                           /* decontaminate */
3551             sv_setpvn(TARG, "", 0);
3552             SETs(TARG);
3553         }
3554         else {
3555             STRLEN nchar = utf8_length(s, s + len);
3556
3557             (void)SvUPGRADE(TARG, SVt_PV);
3558             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3559             (void)SvPOK_only(TARG);
3560             d = (U8*)SvPVX(TARG);
3561             send = s + len;
3562             while (s < send) {
3563                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3564 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3565                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3566                      /*
3567                       * Now if the sigma is NOT followed by
3568                       * /$ignorable_sequence$cased_letter/;
3569                       * and it IS preceded by
3570                       * /$cased_letter$ignorable_sequence/;
3571                       * where $ignorable_sequence is
3572                       * [\x{2010}\x{AD}\p{Mn}]*
3573                       * and $cased_letter is
3574                       * [\p{Ll}\p{Lo}\p{Lt}]
3575                       * then it should be mapped to 0x03C2,
3576                       * (GREEK SMALL LETTER FINAL SIGMA),
3577                       * instead of staying 0x03A3.
3578                       * See lib/unicore/SpecCase.txt.
3579                       */
3580                 }
3581                 Copy(tmpbuf, d, ulen, U8);
3582                 d += ulen;
3583                 s += UTF8SKIP(s);
3584             }
3585             *d = '\0';
3586             SvUTF8_on(TARG);
3587             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3588             SETs(TARG);
3589         }
3590     }
3591     else {
3592         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3593             dTARGET;
3594             SvUTF8_off(TARG);                           /* decontaminate */
3595             sv_setsv_nomg(TARG, sv);
3596             sv = TARG;
3597             SETs(sv);
3598         }
3599
3600         s = (U8*)SvPV_force_nomg(sv, len);
3601         if (len) {
3602             register U8 *send = s + len;
3603
3604             if (IN_LOCALE_RUNTIME) {
3605                 TAINT;
3606                 SvTAINTED_on(sv);
3607                 for (; s < send; s++)
3608                     *s = toLOWER_LC(*s);
3609             }
3610             else {
3611                 for (; s < send; s++)
3612                     *s = toLOWER(*s);
3613             }
3614         }
3615     }
3616     SvSETMAGIC(sv);
3617     RETURN;
3618 }
3619
3620 PP(pp_quotemeta)
3621 {
3622     dSP; dTARGET;
3623     SV *sv = TOPs;
3624     STRLEN len;
3625     register char *s = SvPV(sv,len);
3626     register char *d;
3627
3628     SvUTF8_off(TARG);                           /* decontaminate */
3629     if (len) {
3630         (void)SvUPGRADE(TARG, SVt_PV);
3631         SvGROW(TARG, (len * 2) + 1);
3632         d = SvPVX(TARG);
3633         if (DO_UTF8(sv)) {
3634             while (len) {
3635                 if (UTF8_IS_CONTINUED(*s)) {
3636                     STRLEN ulen = UTF8SKIP(s);
3637                     if (ulen > len)
3638                         ulen = len;
3639                     len -= ulen;
3640                     while (ulen--)
3641                         *d++ = *s++;
3642                 }
3643                 else {
3644                     if (!isALNUM(*s))
3645                         *d++ = '\\';
3646                     *d++ = *s++;
3647                     len--;
3648                 }
3649             }
3650             SvUTF8_on(TARG);
3651         }
3652         else {
3653             while (len--) {
3654                 if (!isALNUM(*s))
3655                     *d++ = '\\';
3656                 *d++ = *s++;
3657             }
3658         }
3659         *d = '\0';
3660         SvCUR_set(TARG, d - SvPVX(TARG));
3661         (void)SvPOK_only_UTF8(TARG);
3662     }
3663     else
3664         sv_setpvn(TARG, s, len);
3665     SETs(TARG);
3666     if (SvSMAGICAL(TARG))
3667         mg_set(TARG);
3668     RETURN;
3669 }
3670
3671 /* Arrays. */
3672
3673 PP(pp_aslice)
3674 {
3675     dSP; dMARK; dORIGMARK;
3676     register SV** svp;
3677     register AV* av = (AV*)POPs;
3678     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3679     I32 arybase = PL_curcop->cop_arybase;
3680     I32 elem;
3681
3682     if (SvTYPE(av) == SVt_PVAV) {
3683         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3684             I32 max = -1;
3685             for (svp = MARK + 1; svp <= SP; svp++) {
3686                 elem = SvIVx(*svp);
3687                 if (elem > max)
3688                     max = elem;
3689             }
3690             if (max > AvMAX(av))
3691                 av_extend(av, max);
3692         }
3693         while (++MARK <= SP) {
3694             elem = SvIVx(*MARK);
3695
3696             if (elem > 0)
3697                 elem -= arybase;
3698             svp = av_fetch(av, elem, lval);
3699             if (lval) {
3700                 if (!svp || *svp == &PL_sv_undef)
3701                     DIE(aTHX_ PL_no_aelem, elem);
3702                 if (PL_op->op_private & OPpLVAL_INTRO)
3703                     save_aelem(av, elem, svp);
3704             }
3705             *MARK = svp ? *svp : &PL_sv_undef;
3706         }
3707     }
3708     if (GIMME != G_ARRAY) {
3709         MARK = ORIGMARK;
3710         *++MARK = *SP;
3711         SP = MARK;
3712     }
3713     RETURN;
3714 }
3715
3716 /* Associative arrays. */
3717
3718 PP(pp_each)
3719 {
3720     dSP;
3721     HV *hash = (HV*)POPs;
3722     HE *entry;
3723     I32 gimme = GIMME_V;
3724
3725     PUTBACK;
3726     /* might clobber stack_sp */
3727     entry = hv_iternext(hash);
3728     SPAGAIN;
3729
3730     EXTEND(SP, 2);
3731     if (entry) {
3732         SV* sv = hv_iterkeysv(entry);
3733         PUSHs(sv);      /* won't clobber stack_sp */
3734         if (gimme == G_ARRAY) {
3735             SV *val;
3736             PUTBACK;
3737             /* might clobber stack_sp */
3738             val = hv_iterval(hash, entry);
3739             SPAGAIN;
3740             PUSHs(val);
3741         }
3742     }
3743     else if (gimme == G_SCALAR)
3744         RETPUSHUNDEF;
3745
3746     RETURN;
3747 }
3748
3749 PP(pp_values)
3750 {
3751     return do_kv();
3752 }
3753
3754 PP(pp_keys)
3755 {
3756     return do_kv();
3757 }
3758
3759 PP(pp_delete)
3760 {
3761     dSP;
3762     I32 gimme = GIMME_V;
3763     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3764     SV *sv;
3765     HV *hv;
3766
3767     if (PL_op->op_private & OPpSLICE) {
3768         dMARK; dORIGMARK;
3769         U32 hvtype;
3770         hv = (HV*)POPs;
3771         hvtype = SvTYPE(hv);
3772         if (hvtype == SVt_PVHV) {                       /* hash element */
3773             while (++MARK <= SP) {
3774                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3775                 *MARK = sv ? sv : &PL_sv_undef;
3776             }
3777         }
3778         else if (hvtype == SVt_PVAV) {                  /* array element */
3779             if (PL_op->op_flags & OPf_SPECIAL) {
3780                 while (++MARK <= SP) {
3781                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3782                     *MARK = sv ? sv : &PL_sv_undef;
3783                 }
3784             }
3785         }
3786         else
3787             DIE(aTHX_ "Not a HASH reference");
3788         if (discard)
3789             SP = ORIGMARK;
3790         else if (gimme == G_SCALAR) {
3791             MARK = ORIGMARK;
3792             *++MARK = *SP;
3793             SP = MARK;
3794         }
3795     }
3796     else {
3797         SV *keysv = POPs;
3798         hv = (HV*)POPs;
3799         if (SvTYPE(hv) == SVt_PVHV)
3800             sv = hv_delete_ent(hv, keysv, discard, 0);
3801         else if (SvTYPE(hv) == SVt_PVAV) {
3802             if (PL_op->op_flags & OPf_SPECIAL)
3803                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3804             else
3805                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3806         }
3807         else
3808             DIE(aTHX_ "Not a HASH reference");
3809         if (!sv)
3810             sv = &PL_sv_undef;
3811         if (!discard)
3812             PUSHs(sv);
3813     }
3814     RETURN;
3815 }
3816
3817 PP(pp_exists)
3818 {
3819     dSP;
3820     SV *tmpsv;
3821     HV *hv;
3822
3823     if (PL_op->op_private & OPpEXISTS_SUB) {
3824         GV *gv;
3825         CV *cv;
3826         SV *sv = POPs;
3827         cv = sv_2cv(sv, &hv, &gv, FALSE);
3828         if (cv)
3829             RETPUSHYES;
3830         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3831             RETPUSHYES;
3832         RETPUSHNO;
3833     }
3834     tmpsv = POPs;
3835     hv = (HV*)POPs;
3836     if (SvTYPE(hv) == SVt_PVHV) {
3837         if (hv_exists_ent(hv, tmpsv, 0))
3838             RETPUSHYES;
3839     }
3840     else if (SvTYPE(hv) == SVt_PVAV) {
3841         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3842             if (av_exists((AV*)hv, SvIV(tmpsv)))
3843                 RETPUSHYES;
3844         }
3845     }
3846     else {
3847         DIE(aTHX_ "Not a HASH reference");
3848     }
3849     RETPUSHNO;
3850 }
3851
3852 PP(pp_hslice)
3853 {
3854     dSP; dMARK; dORIGMARK;
3855     register HV *hv = (HV*)POPs;
3856     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3857     bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3858     bool other_magic = FALSE;
3859
3860     if (localizing) {
3861         MAGIC *mg;
3862         HV *stash;
3863
3864         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3865             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3866              /* Try to preserve the existenceness of a tied hash
3867               * element by using EXISTS and DELETE if possible.
3868               * Fallback to FETCH and STORE otherwise */
3869              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3870              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3871              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3872     }
3873
3874     while (++MARK <= SP) {
3875         SV *keysv = *MARK;
3876         SV **svp;
3877         HE *he;
3878         bool preeminent = FALSE;
3879
3880         if (localizing) {
3881             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3882                 hv_exists_ent(hv, keysv, 0);
3883         }
3884
3885         he = hv_fetch_ent(hv, keysv, lval, 0);
3886         svp = he ? &HeVAL(he) : 0;
3887
3888         if (lval) {
3889             if (!svp || *svp == &PL_sv_undef) {
3890                 STRLEN n_a;
3891                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3892             }
3893             if (localizing) {
3894                 if (preeminent)
3895                     save_helem(hv, keysv, svp);
3896                 else {
3897                     STRLEN keylen;
3898                     char *key = SvPV(keysv, keylen);
3899                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
3900                 }
3901             }
3902         }
3903         *MARK = svp ? *svp : &PL_sv_undef;
3904     }
3905     if (GIMME != G_ARRAY) {
3906         MARK = ORIGMARK;
3907         *++MARK = *SP;
3908         SP = MARK;
3909     }
3910     RETURN;
3911 }
3912
3913 /* List operators. */
3914
3915 PP(pp_list)
3916 {
3917     dSP; dMARK;
3918     if (GIMME != G_ARRAY) {
3919         if (++MARK <= SP)
3920             *MARK = *SP;                /* unwanted list, return last item */
3921         else
3922             *MARK = &PL_sv_undef;
3923         SP = MARK;
3924     }
3925     RETURN;
3926 }
3927
3928 PP(pp_lslice)
3929 {
3930     dSP;
3931     SV **lastrelem = PL_stack_sp;
3932     SV **lastlelem = PL_stack_base + POPMARK;
3933     SV **firstlelem = PL_stack_base + POPMARK + 1;
3934     register SV **firstrelem = lastlelem + 1;
3935     I32 arybase = PL_curcop->cop_arybase;
3936     I32 lval = PL_op->op_flags & OPf_MOD;
3937     I32 is_something_there = lval;
3938
3939     register I32 max = lastrelem - lastlelem;
3940     register SV **lelem;
3941     register I32 ix;
3942
3943     if (GIMME != G_ARRAY) {
3944         ix = SvIVx(*lastlelem);
3945         if (ix < 0)
3946             ix += max;
3947         else
3948             ix -= arybase;
3949         if (ix < 0 || ix >= max)
3950             *firstlelem = &PL_sv_undef;
3951         else
3952             *firstlelem = firstrelem[ix];
3953         SP = firstlelem;
3954         RETURN;
3955     }
3956
3957     if (max == 0) {
3958         SP = firstlelem - 1;
3959         RETURN;
3960     }
3961
3962     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3963         ix = SvIVx(*lelem);
3964         if (ix < 0)
3965             ix += max;
3966         else
3967             ix -= arybase;
3968         if (ix < 0 || ix >= max)
3969             *lelem = &PL_sv_undef;
3970         else {
3971             is_something_there = TRUE;
3972             if (!(*lelem = firstrelem[ix]))
3973                 *lelem = &PL_sv_undef;
3974         }
3975     }
3976     if (is_something_there)
3977         SP = lastlelem;
3978     else
3979         SP = firstlelem - 1;
3980     RETURN;
3981 }
3982
3983 PP(pp_anonlist)
3984 {
3985     dSP; dMARK; dORIGMARK;
3986     I32 items = SP - MARK;
3987     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3988     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3989     XPUSHs(av);
3990     RETURN;
3991 }
3992
3993 PP(pp_anonhash)
3994 {
3995     dSP; dMARK; dORIGMARK;
3996     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3997
3998     while (MARK < SP) {
3999         SV* key = *++MARK;
4000         SV *val = NEWSV(46, 0);
4001         if (MARK < SP)
4002             sv_setsv(val, *++MARK);
4003         else if (ckWARN(WARN_MISC))
4004             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4005         (void)hv_store_ent(hv,key,val,0);
4006     }
4007     SP = ORIGMARK;
4008     XPUSHs((SV*)hv);
4009     RETURN;
4010 }
4011
4012 PP(pp_splice)
4013 {
4014     dSP; dMARK; dORIGMARK;
4015     register AV *ary = (AV*)*++MARK;
4016     register SV **src;
4017     register SV **dst;
4018     register I32 i;
4019     register I32 offset;
4020     register I32 length;
4021     I32 newlen;
4022     I32 after;
4023     I32 diff;
4024     SV **tmparyval = 0;
4025     MAGIC *mg;
4026
4027     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4028         *MARK-- = SvTIED_obj((SV*)ary, mg);
4029         PUSHMARK(MARK);
4030         PUTBACK;
4031         ENTER;
4032         call_method("SPLICE",GIMME_V);
4033         LEAVE;
4034         SPAGAIN;
4035         RETURN;
4036     }
4037
4038     SP++;
4039
4040     if (++MARK < SP) {
4041         offset = i = SvIVx(*MARK);
4042         if (offset < 0)
4043             offset += AvFILLp(ary) + 1;
4044         else
4045             offset -= PL_curcop->cop_arybase;
4046         if (offset < 0)
4047             DIE(aTHX_ PL_no_aelem, i);
4048         if (++MARK < SP) {
4049             length = SvIVx(*MARK++);
4050             if (length < 0) {
4051                 length += AvFILLp(ary) - offset + 1;
4052                 if (length < 0)
4053                     length = 0;
4054             }
4055         }
4056         else
4057             length = AvMAX(ary) + 1;            /* close enough to infinity */
4058     }
4059     else {
4060         offset = 0;
4061         length = AvMAX(ary) + 1;
4062     }
4063     if (offset > AvFILLp(ary) + 1) {
4064         if (ckWARN(WARN_MISC))
4065             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4066         offset = AvFILLp(ary) + 1;
4067     }
4068     after = AvFILLp(ary) + 1 - (offset + length);
4069     if (after < 0) {                            /* not that much array */
4070         length += after;                        /* offset+length now in array */
4071         after = 0;
4072         if (!AvALLOC(ary))
4073             av_extend(ary, 0);
4074     }
4075
4076     /* At this point, MARK .. SP-1 is our new LIST */
4077
4078     newlen = SP - MARK;
4079     diff = newlen - length;
4080     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4081         av_reify(ary);
4082
4083     if (diff < 0) {                             /* shrinking the area */
4084         if (newlen) {
4085             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4086             Copy(MARK, tmparyval, newlen, SV*);
4087         }
4088
4089         MARK = ORIGMARK + 1;
4090         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4091             MEXTEND(MARK, length);
4092             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4093             if (AvREAL(ary)) {
4094                 EXTEND_MORTAL(length);
4095                 for (i = length, dst = MARK; i; i--) {
4096                     sv_2mortal(*dst);   /* free them eventualy */
4097                     dst++;
4098                 }
4099             }
4100             MARK += length - 1;
4101         }
4102         else {
4103             *MARK = AvARRAY(ary)[offset+length-1];
4104             if (AvREAL(ary)) {
4105                 sv_2mortal(*MARK);
4106                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4107                     SvREFCNT_dec(*dst++);       /* free them now */
4108             }
4109         }
4110         AvFILLp(ary) += diff;
4111
4112         /* pull up or down? */
4113
4114         if (offset < after) {                   /* easier to pull up */
4115             if (offset) {                       /* esp. if nothing to pull */
4116                 src = &AvARRAY(ary)[offset-1];
4117                 dst = src - diff;               /* diff is negative */
4118                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4119                     *dst-- = *src--;
4120             }
4121             dst = AvARRAY(ary);
4122             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4123             AvMAX(ary) += diff;
4124         }
4125         else {
4126             if (after) {                        /* anything to pull down? */
4127                 src = AvARRAY(ary) + offset + length;
4128                 dst = src + diff;               /* diff is negative */
4129                 Move(src, dst, after, SV*);
4130             }
4131             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4132                                                 /* avoid later double free */
4133         }
4134         i = -diff;
4135         while (i)
4136             dst[--i] = &PL_sv_undef;
4137
4138         if (newlen) {
4139             for (src = tmparyval, dst = AvARRAY(ary) + offset;
4140               newlen; newlen--) {
4141                 *dst = NEWSV(46, 0);
4142                 sv_setsv(*dst++, *src++);
4143             }
4144             Safefree(tmparyval);
4145         }
4146     }
4147     else {                                      /* no, expanding (or same) */
4148         if (length) {
4149             New(452, tmparyval, length, SV*);   /* so remember deletion */
4150             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4151         }
4152
4153         if (diff > 0) {                         /* expanding */
4154
4155             /* push up or down? */
4156
4157             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4158                 if (offset) {
4159                     src = AvARRAY(ary);
4160                     dst = src - diff;
4161                     Move(src, dst, offset, SV*);
4162                 }
4163                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4164                 AvMAX(ary) += diff;
4165                 AvFILLp(ary) += diff;
4166             }
4167             else {
4168                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4169                     av_extend(ary, AvFILLp(ary) + diff);
4170                 AvFILLp(ary) += diff;
4171
4172                 if (after) {
4173                     dst = AvARRAY(ary) + AvFILLp(ary);
4174                     src = dst - diff;
4175                     for (i = after; i; i--) {
4176                         *dst-- = *src--;
4177                     }
4178                 }
4179             }
4180         }
4181
4182         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4183             *dst = NEWSV(46, 0);
4184             sv_setsv(*dst++, *src++);
4185         }
4186         MARK = ORIGMARK + 1;
4187         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4188             if (length) {
4189                 Copy(tmparyval, MARK, length, SV*);
4190                 if (AvREAL(ary)) {
4191                     EXTEND_MORTAL(length);
4192                     for (i = length, dst = MARK; i; i--) {
4193                         sv_2mortal(*dst);       /* free them eventualy */
4194                         dst++;
4195                     }
4196                 }
4197                 Safefree(tmparyval);
4198             }
4199             MARK += length - 1;
4200         }
4201         else if (length--) {
4202             *MARK = tmparyval[length];
4203             if (AvREAL(ary)) {
4204                 sv_2mortal(*MARK);
4205                 while (length-- > 0)
4206                     SvREFCNT_dec(tmparyval[length]);
4207             }
4208             Safefree(tmparyval);
4209         }
4210         else
4211             *MARK = &PL_sv_undef;
4212     }
4213     SP = MARK;
4214     RETURN;
4215 }
4216
4217 PP(pp_push)
4218 {
4219     dSP; dMARK; dORIGMARK; dTARGET;
4220     register AV *ary = (AV*)*++MARK;
4221     register SV *sv = &PL_sv_undef;
4222     MAGIC *mg;
4223
4224     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4225         *MARK-- = SvTIED_obj((SV*)ary, mg);
4226         PUSHMARK(MARK);
4227         PUTBACK;
4228         ENTER;
4229         call_method("PUSH",G_SCALAR|G_DISCARD);
4230         LEAVE;
4231         SPAGAIN;
4232     }
4233     else {
4234         /* Why no pre-extend of ary here ? */
4235         for (++MARK; MARK <= SP; MARK++) {
4236             sv = NEWSV(51, 0);
4237             if (*MARK)
4238                 sv_setsv(sv, *MARK);
4239             av_push(ary, sv);
4240         }
4241     }
4242     SP = ORIGMARK;
4243     PUSHi( AvFILL(ary) + 1 );
4244     RETURN;
4245 }
4246
4247 PP(pp_pop)
4248 {
4249     dSP;
4250     AV *av = (AV*)POPs;
4251     SV *sv = av_pop(av);
4252     if (AvREAL(av))
4253         (void)sv_2mortal(sv);
4254     PUSHs(sv);
4255     RETURN;
4256 }
4257
4258 PP(pp_shift)
4259 {
4260     dSP;
4261     AV *av = (AV*)POPs;
4262     SV *sv = av_shift(av);
4263     EXTEND(SP, 1);
4264     if (!sv)
4265         RETPUSHUNDEF;
4266     if (AvREAL(av))
4267         (void)sv_2mortal(sv);
4268     PUSHs(sv);
4269     RETURN;
4270 }
4271
4272 PP(pp_unshift)
4273 {
4274     dSP; dMARK; dORIGMARK; dTARGET;
4275     register AV *ary = (AV*)*++MARK;
4276     register SV *sv;
4277     register I32 i = 0;
4278     MAGIC *mg;
4279
4280     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4281         *MARK-- = SvTIED_obj((SV*)ary, mg);
4282         PUSHMARK(MARK);
4283         PUTBACK;
4284         ENTER;
4285         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4286         LEAVE;
4287         SPAGAIN;
4288     }
4289     else {
4290         av_unshift(ary, SP - MARK);
4291         while (MARK < SP) {
4292             sv = NEWSV(27, 0);
4293             sv_setsv(sv, *++MARK);
4294             (void)av_store(ary, i++, sv);
4295         }
4296     }
4297     SP = ORIGMARK;
4298     PUSHi( AvFILL(ary) + 1 );
4299     RETURN;
4300 }
4301
4302 PP(pp_reverse)
4303 {
4304     dSP; dMARK;
4305     register SV *tmp;
4306     SV **oldsp = SP;
4307
4308     if (GIMME == G_ARRAY) {
4309         MARK++;
4310         while (MARK < SP) {
4311             tmp = *MARK;
4312             *MARK++ = *SP;
4313             *SP-- = tmp;
4314         }
4315         /* safe as long as stack cannot get extended in the above */
4316         SP = oldsp;
4317     }
4318     else {
4319         register char *up;
4320         register char *down;
4321         register I32 tmp;
4322         dTARGET;
4323         STRLEN len;
4324
4325         SvUTF8_off(TARG);                               /* decontaminate */
4326         if (SP - MARK > 1)
4327             do_join(TARG, &PL_sv_no, MARK, SP);
4328         else
4329             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4330         up = SvPV_force(TARG, len);
4331         if (len > 1) {
4332             if (DO_UTF8(TARG)) {        /* first reverse each character */
4333                 U8* s = (U8*)SvPVX(TARG);
4334                 U8* send = (U8*)(s + len);
4335                 while (s < send) {
4336                     if (UTF8_IS_INVARIANT(*s)) {
4337                         s++;
4338                         continue;
4339                     }
4340                     else {
4341                         if (!utf8_to_uvchr(s, 0))
4342                             break;
4343                         up = (char*)s;
4344                         s += UTF8SKIP(s);
4345                         down = (char*)(s - 1);
4346                         /* reverse this character */
4347                         while (down > up) {
4348                             tmp = *up;
4349                             *up++ = *down;
4350                             *down-- = (char)tmp;
4351                         }
4352                     }
4353                 }
4354                 up = SvPVX(TARG);
4355             }
4356             down = SvPVX(TARG) + len - 1;
4357             while (down > up) {
4358                 tmp = *up;
4359                 *up++ = *down;
4360                 *down-- = (char)tmp;
4361             }
4362             (void)SvPOK_only_UTF8(TARG);
4363         }
4364         SP = MARK + 1;
4365         SETTARG;
4366     }
4367     RETURN;
4368 }
4369
4370 PP(pp_split)
4371 {
4372     dSP; dTARG;
4373     AV *ary;
4374     register IV limit = POPi;                   /* note, negative is forever */
4375     SV *sv = POPs;
4376     STRLEN len;
4377     register char *s = SvPV(sv, len);
4378     bool do_utf8 = DO_UTF8(sv);
4379     char *strend = s + len;
4380     register PMOP *pm;
4381     register REGEXP *rx;
4382     register SV *dstr;
4383     register char *m;
4384     I32 iters = 0;
4385     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4386     I32 maxiters = slen + 10;
4387     I32 i;
4388     char *orig;
4389     I32 origlimit = limit;
4390     I32 realarray = 0;
4391     I32 base;
4392     AV *oldstack = PL_curstack;
4393     I32 gimme = GIMME_V;
4394     I32 oldsave = PL_savestack_ix;
4395     I32 make_mortal = 1;
4396     MAGIC *mg = (MAGIC *) NULL;
4397
4398 #ifdef DEBUGGING
4399     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4400 #else
4401     pm = (PMOP*)POPs;
4402 #endif
4403     if (!pm || !s)
4404         DIE(aTHX_ "panic: pp_split");
4405     rx = PM_GETRE(pm);
4406
4407     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4408              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4409
4410     RX_MATCH_UTF8_set(rx, do_utf8);
4411
4412     if (pm->op_pmreplroot) {
4413 #ifdef USE_ITHREADS
4414         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4415 #else
4416         ary = GvAVn((GV*)pm->op_pmreplroot);
4417 #endif
4418     }
4419     else if (gimme != G_ARRAY)
4420         ary = GvAVn(PL_defgv);
4421     else
4422         ary = Nullav;
4423     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4424         realarray = 1;
4425         PUTBACK;
4426         av_extend(ary,0);
4427         av_clear(ary);
4428         SPAGAIN;
4429         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4430             PUSHMARK(SP);
4431             XPUSHs(SvTIED_obj((SV*)ary, mg));
4432         }
4433         else {
4434             if (!AvREAL(ary)) {
4435                 AvREAL_on(ary);
4436                 AvREIFY_off(ary);
4437                 for (i = AvFILLp(ary); i >= 0; i--)
4438                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4439             }
4440             /* temporarily switch stacks */
4441             SWITCHSTACK(PL_curstack, ary);
4442             PL_curstackinfo->si_stack = ary;
4443             make_mortal = 0;
4444         }
4445     }
4446     base = SP - PL_stack_base;
4447     orig = s;
4448     if (pm->op_pmflags & PMf_SKIPWHITE) {
4449         if (pm->op_pmflags & PMf_LOCALE) {
4450             while (isSPACE_LC(*s))
4451                 s++;
4452         }
4453         else {
4454             while (isSPACE(*s))
4455                 s++;
4456         }
4457     }
4458     if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4459         SAVEINT(PL_multiline);
4460         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4461     }
4462
4463     if (!limit)
4464         limit = maxiters + 2;
4465     if (pm->op_pmflags & PMf_WHITE) {
4466         while (--limit) {
4467             m = s;
4468             while (m < strend &&
4469                    !((pm->op_pmflags & PMf_LOCALE)
4470                      ? isSPACE_LC(*m) : isSPACE(*m)))
4471                 ++m;
4472             if (m >= strend)
4473                 break;
4474
4475             dstr = NEWSV(30, m-s);
4476             sv_setpvn(dstr, s, m-s);
4477             if (make_mortal)
4478                 sv_2mortal(dstr);
4479             if (do_utf8)
4480                 (void)SvUTF8_on(dstr);
4481             XPUSHs(dstr);
4482
4483             s = m + 1;
4484             while (s < strend &&
4485                    ((pm->op_pmflags & PMf_LOCALE)
4486                     ? isSPACE_LC(*s) : isSPACE(*s)))
4487                 ++s;
4488         }
4489     }
4490     else if (strEQ("^", rx->precomp)) {
4491         while (--limit) {
4492             /*SUPPRESS 530*/
4493             for (m = s; m < strend && *m != '\n'; m++) ;
4494             m++;
4495             if (m >= strend)
4496                 break;
4497             dstr = NEWSV(30, m-s);
4498             sv_setpvn(dstr, s, m-s);
4499             if (make_mortal)
4500                 sv_2mortal(dstr);
4501             if (do_utf8)
4502                 (void)SvUTF8_on(dstr);
4503             XPUSHs(dstr);
4504             s = m;
4505         }
4506     }
4507     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4508              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4509              && (rx->reganch & ROPT_CHECK_ALL)
4510              && !(rx->reganch & ROPT_ANCH)) {
4511         int tail = (rx->reganch & RE_INTUIT_TAIL);
4512         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4513
4514         len = rx->minlen;
4515         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4516             STRLEN n_a;
4517             char c = *SvPV(csv, n_a);
4518             while (--limit) {
4519                 /*SUPPRESS 530*/
4520                 for (m = s; m < strend && *m != c; m++) ;
4521                 if (m >= strend)
4522                     break;
4523                 dstr = NEWSV(30, m-s);
4524                 sv_setpvn(dstr, s, m-s);
4525                 if (make_mortal)
4526                     sv_2mortal(dstr);
4527                 if (do_utf8)
4528                     (void)SvUTF8_on(dstr);
4529                 XPUSHs(dstr);
4530                 /* The rx->minlen is in characters but we want to step
4531                  * s ahead by bytes. */
4532                 if (do_utf8)
4533                     s = (char*)utf8_hop((U8*)m, len);
4534                 else
4535                     s = m + len; /* Fake \n at the end */
4536             }
4537         }
4538         else {
4539 #ifndef lint
4540             while (s < strend && --limit &&
4541               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4542                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4543 #endif
4544             {
4545                 dstr = NEWSV(31, m-s);
4546                 sv_setpvn(dstr, s, m-s);
4547                 if (make_mortal)
4548                     sv_2mortal(dstr);
4549                 if (do_utf8)
4550                     (void)SvUTF8_on(dstr);
4551                 XPUSHs(dstr);
4552                 /* The rx->minlen is in characters but we want to step
4553                  * s ahead by bytes. */
4554                 if (do_utf8)
4555                     s = (char*)utf8_hop((U8*)m, len);
4556                 else
4557                     s = m + len; /* Fake \n at the end */
4558             }
4559         }
4560     }
4561     else {
4562         maxiters += slen * rx->nparens;
4563         while (s < strend && --limit)
4564         {
4565             PUTBACK;
4566             i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4567             SPAGAIN;
4568             if (i == 0)
4569                 break;
4570             TAINT_IF(RX_MATCH_TAINTED(rx));
4571             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4572                 m = s;
4573                 s = orig;
4574                 orig = rx->subbeg;
4575                 s = orig + (m - s);
4576                 strend = s + (strend - m);
4577             }
4578             m = rx->startp[0] + orig;
4579             dstr = NEWSV(32, m-s);
4580             sv_setpvn(dstr, s, m-s);
4581             if (make_mortal)
4582                 sv_2mortal(dstr);
4583             if (do_utf8)
4584                 (void)SvUTF8_on(dstr);
4585             XPUSHs(dstr);
4586             if (rx->nparens) {
4587                 for (i = 1; i <= (I32)rx->nparens; i++) {
4588                     s = rx->startp[i] + orig;
4589                     m = rx->endp[i] + orig;
4590
4591                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4592                        parens that didn't match -- they should be set to
4593                        undef, not the empty string */
4594                     if (m >= orig && s >= orig) {
4595                         dstr = NEWSV(33, m-s);
4596                         sv_setpvn(dstr, s, m-s);
4597                     }
4598                     else
4599                         dstr = &PL_sv_undef;  /* undef, not "" */
4600                     if (make_mortal)
4601                         sv_2mortal(dstr);
4602                     if (do_utf8)
4603                         (void)SvUTF8_on(dstr);
4604                     XPUSHs(dstr);
4605                 }
4606             }
4607             s = rx->endp[0] + orig;
4608         }
4609     }
4610
4611     LEAVE_SCOPE(oldsave);
4612     iters = (SP - PL_stack_base) - base;
4613     if (iters > maxiters)
4614         DIE(aTHX_ "Split loop");
4615
4616     /* keep field after final delim? */
4617     if (s < strend || (iters && origlimit)) {
4618         STRLEN l = strend - s;
4619         dstr = NEWSV(34, l);
4620         sv_setpvn(dstr, s, l);
4621         if (make_mortal)
4622             sv_2mortal(dstr);
4623         if (do_utf8)
4624             (void)SvUTF8_on(dstr);
4625         XPUSHs(dstr);
4626         iters++;
4627     }
4628     else if (!origlimit) {
4629         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4630             if (TOPs && !make_mortal)
4631                 sv_2mortal(TOPs);
4632             iters--;
4633             SP--;
4634         }
4635     }
4636
4637     if (realarray) {
4638         if (!mg) {
4639             SWITCHSTACK(ary, oldstack);
4640             PL_curstackinfo->si_stack = oldstack;
4641             if (SvSMAGICAL(ary)) {
4642                 PUTBACK;
4643                 mg_set((SV*)ary);
4644                 SPAGAIN;
4645             }
4646             if (gimme == G_ARRAY) {
4647                 EXTEND(SP, iters);
4648                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4649                 SP += iters;
4650                 RETURN;
4651             }
4652         }
4653         else {
4654             PUTBACK;
4655             ENTER;
4656             call_method("PUSH",G_SCALAR|G_DISCARD);
4657             LEAVE;
4658             SPAGAIN;
4659             if (gimme == G_ARRAY) {
4660                 /* EXTEND should not be needed - we just popped them */
4661                 EXTEND(SP, iters);
4662                 for (i=0; i < iters; i++) {
4663                     SV **svp = av_fetch(ary, i, FALSE);
4664                     PUSHs((svp) ? *svp : &PL_sv_undef);
4665                 }
4666                 RETURN;
4667             }
4668         }
4669     }
4670     else {
4671         if (gimme == G_ARRAY)
4672             RETURN;
4673     }
4674
4675     GETTARGET;
4676     PUSHi(iters);
4677     RETURN;
4678 }
4679
4680 PP(pp_lock)
4681 {
4682     dSP;
4683     dTOPss;
4684     SV *retsv = sv;
4685     SvLOCK(sv);
4686     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4687         || SvTYPE(retsv) == SVt_PVCV) {
4688         retsv = refto(retsv);
4689     }
4690     SETs(retsv);
4691     RETURN;
4692 }
4693
4694 PP(pp_threadsv)
4695 {
4696     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4697 }