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