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