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