pp.c

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