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