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