pp.c

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