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