pp.c

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