pp.c

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