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 (!SvOK(TOPs))
2804         SETu(0);
2805       else if (SvIOK(TOPs)) {
2806         if (SvIsUV(TOPs)) {
2807             UV uv = TOPu;
2808             SETu(uv);
2809         } else
2810             SETi(iv);
2811       } else {
2812           value = TOPn;
2813           if (value >= 0.0) {
2814               if (value < (NV)UV_MAX + 0.5) {
2815                   SETu(U_V(value));
2816               } else {
2817                   SETn(Perl_floor(value));
2818               }
2819           }
2820           else {
2821               if (value > (NV)IV_MIN - 0.5) {
2822                   SETi(I_V(value));
2823               } else {
2824                   SETn(Perl_ceil(value));
2825               }
2826           }
2827       }
2828     }
2829     RETURN;
2830 }
2831
2832 PP(pp_abs)
2833 {
2834     dSP; dTARGET; tryAMAGICun(abs);
2835     {
2836       /* This will cache the NV value if string isn't actually integer  */
2837       IV iv = TOPi;
2838
2839       if (!SvOK(TOPs))
2840         SETu(0);
2841       else if (SvIOK(TOPs)) {
2842         /* IVX is precise  */
2843         if (SvIsUV(TOPs)) {
2844           SETu(TOPu);   /* force it to be numeric only */
2845         } else {
2846           if (iv >= 0) {
2847             SETi(iv);
2848           } else {
2849             if (iv != IV_MIN) {
2850               SETi(-iv);
2851             } else {
2852               /* 2s complement assumption. Also, not really needed as
2853                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2854               SETu(IV_MIN);
2855             }
2856           }
2857         }
2858       } else{
2859         NV value = TOPn;
2860         if (value < 0.0)
2861           value = -value;
2862         SETn(value);
2863       }
2864     }
2865     RETURN;
2866 }
2867
2868
2869 PP(pp_hex)
2870 {
2871     dSP; dTARGET;
2872     char *tmps;
2873     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2874     STRLEN len;
2875     NV result_nv;
2876     UV result_uv;
2877     SV* sv = POPs;
2878
2879     tmps = (SvPVx(sv, len));
2880     if (DO_UTF8(sv)) {
2881          /* If Unicode, try to downgrade
2882           * If not possible, croak. */
2883          SV* tsv = sv_2mortal(newSVsv(sv));
2884
2885          SvUTF8_on(tsv);
2886          sv_utf8_downgrade(tsv, FALSE);
2887          tmps = SvPVX(tsv);
2888     }
2889     result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2890     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2891         XPUSHn(result_nv);
2892     }
2893     else {
2894         XPUSHu(result_uv);
2895     }
2896     RETURN;
2897 }
2898
2899 PP(pp_oct)
2900 {
2901     dSP; dTARGET;
2902     char *tmps;
2903     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2904     STRLEN len;
2905     NV result_nv;
2906     UV result_uv;
2907     SV* sv = POPs;
2908
2909     tmps = (SvPVx(sv, len));
2910     if (DO_UTF8(sv)) {
2911          /* If Unicode, try to downgrade
2912           * If not possible, croak. */
2913          SV* tsv = sv_2mortal(newSVsv(sv));
2914
2915          SvUTF8_on(tsv);
2916          sv_utf8_downgrade(tsv, FALSE);
2917          tmps = SvPVX(tsv);
2918     }
2919     while (*tmps && len && isSPACE(*tmps))
2920         tmps++, len--;
2921     if (*tmps == '0')
2922         tmps++, len--;
2923     if (*tmps == 'x')
2924         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2925     else if (*tmps == 'b')
2926         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2927     else
2928         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2929
2930     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2931         XPUSHn(result_nv);
2932     }
2933     else {
2934         XPUSHu(result_uv);
2935     }
2936     RETURN;
2937 }
2938
2939 /* String stuff. */
2940
2941 PP(pp_length)
2942 {
2943     dSP; dTARGET;
2944     SV *sv = TOPs;
2945
2946     if (DO_UTF8(sv))
2947         SETi(sv_len_utf8(sv));
2948     else
2949         SETi(sv_len(sv));
2950     RETURN;
2951 }
2952
2953 PP(pp_substr)
2954 {
2955     dSP; dTARGET;
2956     SV *sv;
2957     I32 len = 0;
2958     STRLEN curlen;
2959     STRLEN utf8_curlen;
2960     I32 pos;
2961     I32 rem;
2962     I32 fail;
2963     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2964     char *tmps;
2965     I32 arybase = PL_curcop->cop_arybase;
2966     SV *repl_sv = NULL;
2967     char *repl = 0;
2968     STRLEN repl_len;
2969     int num_args = PL_op->op_private & 7;
2970     bool repl_need_utf8_upgrade = FALSE;
2971     bool repl_is_utf8 = FALSE;
2972
2973     SvTAINTED_off(TARG);                        /* decontaminate */
2974     SvUTF8_off(TARG);                           /* decontaminate */
2975     if (num_args > 2) {
2976         if (num_args > 3) {
2977             repl_sv = POPs;
2978             repl = SvPV(repl_sv, repl_len);
2979             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2980         }
2981         len = POPi;
2982     }
2983     pos = POPi;
2984     sv = POPs;
2985     PUTBACK;
2986     if (repl_sv) {
2987         if (repl_is_utf8) {
2988             if (!DO_UTF8(sv))
2989                 sv_utf8_upgrade(sv);
2990         }
2991         else if (DO_UTF8(sv))
2992             repl_need_utf8_upgrade = TRUE;
2993     }
2994     tmps = SvPV(sv, curlen);
2995     if (DO_UTF8(sv)) {
2996         utf8_curlen = sv_len_utf8(sv);
2997         if (utf8_curlen == curlen)
2998             utf8_curlen = 0;
2999         else
3000             curlen = utf8_curlen;
3001     }
3002     else
3003         utf8_curlen = 0;
3004
3005     if (pos >= arybase) {
3006         pos -= arybase;
3007         rem = curlen-pos;
3008         fail = rem;
3009         if (num_args > 2) {
3010             if (len < 0) {
3011                 rem += len;
3012                 if (rem < 0)
3013                     rem = 0;
3014             }
3015             else if (rem > len)
3016                      rem = len;
3017         }
3018     }
3019     else {
3020         pos += curlen;
3021         if (num_args < 3)
3022             rem = curlen;
3023         else if (len >= 0) {
3024             rem = pos+len;
3025             if (rem > (I32)curlen)
3026                 rem = curlen;
3027         }
3028         else {
3029             rem = curlen+len;
3030             if (rem < pos)
3031                 rem = pos;
3032         }
3033         if (pos < 0)
3034             pos = 0;
3035         fail = rem;
3036         rem -= pos;
3037     }
3038     if (fail < 0) {
3039         if (lvalue || repl)
3040             Perl_croak(aTHX_ "substr outside of string");
3041         if (ckWARN(WARN_SUBSTR))
3042             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3043         RETPUSHUNDEF;
3044     }
3045     else {
3046         I32 upos = pos;
3047         I32 urem = rem;
3048         if (utf8_curlen)
3049             sv_pos_u2b(sv, &pos, &rem);
3050         tmps += pos;
3051         /* we either return a PV or an LV. If the TARG hasn't been used
3052          * before, or is of that type, reuse it; otherwise use a mortal
3053          * instead. Note that LVs can have an extended lifetime, so also
3054          * dont reuse if refcount > 1 (bug #20933) */
3055         if (SvTYPE(TARG) > SVt_NULL) {
3056             if ( (SvTYPE(TARG) == SVt_PVLV)
3057                     ? (!lvalue || SvREFCNT(TARG) > 1)
3058                     : lvalue)
3059             {
3060                 TARG = sv_newmortal();
3061             }
3062         }
3063
3064         sv_setpvn(TARG, tmps, rem);
3065 #ifdef USE_LOCALE_COLLATE
3066         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3067 #endif
3068         if (utf8_curlen)
3069             SvUTF8_on(TARG);
3070         if (repl) {
3071             SV* repl_sv_copy = NULL;
3072
3073             if (repl_need_utf8_upgrade) {
3074                 repl_sv_copy = newSVsv(repl_sv);
3075                 sv_utf8_upgrade(repl_sv_copy);
3076                 repl = SvPV(repl_sv_copy, repl_len);
3077                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3078             }
3079             sv_insert(sv, pos, rem, repl, repl_len);
3080             if (repl_is_utf8)
3081                 SvUTF8_on(sv);
3082             if (repl_sv_copy)
3083                 SvREFCNT_dec(repl_sv_copy);
3084         }
3085         else if (lvalue) {              /* it's an lvalue! */
3086             if (!SvGMAGICAL(sv)) {
3087                 if (SvROK(sv)) {
3088                     STRLEN n_a;
3089                     SvPV_force(sv,n_a);
3090                     if (ckWARN(WARN_SUBSTR))
3091                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3092                                 "Attempt to use reference as lvalue in substr");
3093                 }
3094                 if (SvOK(sv))           /* is it defined ? */
3095                     (void)SvPOK_only_UTF8(sv);
3096                 else
3097                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3098             }
3099
3100             if (SvTYPE(TARG) < SVt_PVLV) {
3101                 sv_upgrade(TARG, SVt_PVLV);
3102                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3103             }
3104             else
3105                 (void)SvOK_off(TARG);
3106
3107             LvTYPE(TARG) = 'x';
3108             if (LvTARG(TARG) != sv) {
3109                 if (LvTARG(TARG))
3110                     SvREFCNT_dec(LvTARG(TARG));
3111                 LvTARG(TARG) = SvREFCNT_inc(sv);
3112             }
3113             LvTARGOFF(TARG) = upos;
3114             LvTARGLEN(TARG) = urem;
3115         }
3116     }
3117     SPAGAIN;
3118     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3119     RETURN;
3120 }
3121
3122 PP(pp_vec)
3123 {
3124     dSP; dTARGET;
3125     register IV size   = POPi;
3126     register IV offset = POPi;
3127     register SV *src = POPs;
3128     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3129
3130     SvTAINTED_off(TARG);                /* decontaminate */
3131     if (lvalue) {                       /* it's an lvalue! */
3132         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3133             TARG = sv_newmortal();
3134         if (SvTYPE(TARG) < SVt_PVLV) {
3135             sv_upgrade(TARG, SVt_PVLV);
3136             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3137         }
3138         LvTYPE(TARG) = 'v';
3139         if (LvTARG(TARG) != src) {
3140             if (LvTARG(TARG))
3141                 SvREFCNT_dec(LvTARG(TARG));
3142             LvTARG(TARG) = SvREFCNT_inc(src);
3143         }
3144         LvTARGOFF(TARG) = offset;
3145         LvTARGLEN(TARG) = size;
3146     }
3147
3148     sv_setuv(TARG, do_vecget(src, offset, size));
3149     PUSHs(TARG);
3150     RETURN;
3151 }
3152
3153 PP(pp_index)
3154 {
3155     dSP; dTARGET;
3156     SV *big;
3157     SV *little;
3158     I32 offset;
3159     I32 retval;
3160     char *tmps;
3161     char *tmps2;
3162     STRLEN biglen;
3163     I32 arybase = PL_curcop->cop_arybase;
3164
3165     if (MAXARG < 3)
3166         offset = 0;
3167     else
3168         offset = POPi - arybase;
3169     little = POPs;
3170     big = POPs;
3171     tmps = SvPV(big, biglen);
3172     if (offset > 0 && DO_UTF8(big))
3173         sv_pos_u2b(big, &offset, 0);
3174     if (offset < 0)
3175         offset = 0;
3176     else if (offset > (I32)biglen)
3177         offset = biglen;
3178     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3179       (unsigned char*)tmps + biglen, little, 0)))
3180         retval = -1;
3181     else
3182         retval = tmps2 - tmps;
3183     if (retval > 0 && DO_UTF8(big))
3184         sv_pos_b2u(big, &retval);
3185     PUSHi(retval + arybase);
3186     RETURN;
3187 }
3188
3189 PP(pp_rindex)
3190 {
3191     dSP; dTARGET;
3192     SV *big;
3193     SV *little;
3194     STRLEN blen;
3195     STRLEN llen;
3196     I32 offset;
3197     I32 retval;
3198     char *tmps;
3199     char *tmps2;
3200     I32 arybase = PL_curcop->cop_arybase;
3201
3202     if (MAXARG >= 3)
3203         offset = POPi;
3204     little = POPs;
3205     big = POPs;
3206     tmps2 = SvPV(little, llen);
3207     tmps = SvPV(big, blen);
3208     if (MAXARG < 3)
3209         offset = blen;
3210     else {
3211         if (offset > 0 && DO_UTF8(big))
3212             sv_pos_u2b(big, &offset, 0);
3213         offset = offset - arybase + llen;
3214     }
3215     if (offset < 0)
3216         offset = 0;
3217     else if (offset > (I32)blen)
3218         offset = blen;
3219     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3220                           tmps2, tmps2 + llen)))
3221         retval = -1;
3222     else
3223         retval = tmps2 - tmps;
3224     if (retval > 0 && DO_UTF8(big))
3225         sv_pos_b2u(big, &retval);
3226     PUSHi(retval + arybase);
3227     RETURN;
3228 }
3229
3230 PP(pp_sprintf)
3231 {
3232     dSP; dMARK; dORIGMARK; dTARGET;
3233     do_sprintf(TARG, SP-MARK, MARK+1);
3234     TAINT_IF(SvTAINTED(TARG));
3235     if (DO_UTF8(*(MARK+1)))
3236         SvUTF8_on(TARG);
3237     SP = ORIGMARK;
3238     PUSHTARG;
3239     RETURN;
3240 }
3241
3242 PP(pp_ord)
3243 {
3244     dSP; dTARGET;
3245     SV *argsv = POPs;
3246     STRLEN len;
3247     U8 *s = (U8*)SvPVx(argsv, len);
3248     SV *tmpsv;
3249
3250     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3251         tmpsv = sv_2mortal(newSVsv(argsv));
3252         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3253         argsv = tmpsv;
3254     }
3255
3256     XPUSHu(DO_UTF8(argsv) ?
3257            utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3258            (*s & 0xff));
3259
3260     RETURN;
3261 }
3262
3263 PP(pp_chr)
3264 {
3265     dSP; dTARGET;
3266     char *tmps;
3267     UV value = POPu;
3268
3269     (void)SvUPGRADE(TARG,SVt_PV);
3270
3271     if (value > 255 && !IN_BYTES) {
3272         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3273         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3274         SvCUR_set(TARG, tmps - SvPVX(TARG));
3275         *tmps = '\0';
3276         (void)SvPOK_only(TARG);
3277         SvUTF8_on(TARG);
3278         XPUSHs(TARG);
3279         RETURN;
3280     }
3281
3282     SvGROW(TARG,2);
3283     SvCUR_set(TARG, 1);
3284     tmps = SvPVX(TARG);
3285     *tmps++ = (char)value;
3286     *tmps = '\0';
3287     (void)SvPOK_only(TARG);
3288     if (PL_encoding && !IN_BYTES) {
3289         sv_recode_to_utf8(TARG, PL_encoding);
3290         tmps = SvPVX(TARG);
3291         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3292             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3293             SvGROW(TARG, 3);
3294             tmps = SvPVX(TARG);
3295             SvCUR_set(TARG, 2);
3296             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3297             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3298             *tmps = '\0';
3299             SvUTF8_on(TARG);
3300         }
3301     }
3302     XPUSHs(TARG);
3303     RETURN;
3304 }
3305
3306 PP(pp_crypt)
3307 {
3308     dSP; dTARGET;
3309 #ifdef HAS_CRYPT
3310     dPOPTOPssrl;
3311     STRLEN n_a;
3312     STRLEN len;
3313     char *tmps = SvPV(left, len);
3314
3315     if (DO_UTF8(left)) {
3316          /* If Unicode, try to downgrade.
3317           * If not possible, croak.
3318           * Yes, we made this up.  */
3319          SV* tsv = sv_2mortal(newSVsv(left));
3320
3321          SvUTF8_on(tsv);
3322          sv_utf8_downgrade(tsv, FALSE);
3323          tmps = SvPVX(tsv);
3324     }
3325 #   ifdef USE_ITHREADS
3326 #     ifdef HAS_CRYPT_R
3327     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3328       /* This should be threadsafe because in ithreads there is only
3329        * one thread per interpreter.  If this would not be true,
3330        * we would need a mutex to protect this malloc. */
3331         PL_reentrant_buffer->_crypt_struct_buffer =
3332           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3333 #if defined(__GLIBC__) || defined(__EMX__)
3334         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3335             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3336             /* work around glibc-2.2.5 bug */
3337             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3338         }
3339 #endif
3340     }
3341 #     endif /* HAS_CRYPT_R */
3342 #   endif /* USE_ITHREADS */
3343 #   ifdef FCRYPT
3344     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3345 #   else
3346     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3347 #   endif
3348     SETs(TARG);
3349     RETURN;
3350 #else
3351     DIE(aTHX_
3352       "The crypt() function is unimplemented due to excessive paranoia.");
3353 #endif
3354 }
3355
3356 PP(pp_ucfirst)
3357 {
3358     dSP;
3359     SV *sv = TOPs;
3360     register U8 *s;
3361     STRLEN slen;
3362
3363     SvGETMAGIC(sv);
3364     if (DO_UTF8(sv) &&
3365         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3366         UTF8_IS_START(*s)) {
3367         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3368         STRLEN ulen;
3369         STRLEN tculen;
3370
3371         utf8_to_uvchr(s, &ulen);
3372         toTITLE_utf8(s, tmpbuf, &tculen);
3373         utf8_to_uvchr(tmpbuf, 0);
3374
3375         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3376             dTARGET;
3377             /* slen is the byte length of the whole SV.
3378              * ulen is the byte length of the original Unicode character
3379              * stored as UTF-8 at s.
3380              * tculen is the byte length of the freshly titlecased
3381              * Unicode character stored as UTF-8 at tmpbuf.
3382              * We first set the result to be the titlecased character,
3383              * and then append the rest of the SV data. */
3384             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3385             if (slen > ulen)
3386                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3387             SvUTF8_on(TARG);
3388             SETs(TARG);
3389         }
3390         else {
3391             s = (U8*)SvPV_force_nomg(sv, slen);
3392             Copy(tmpbuf, s, tculen, U8);
3393         }
3394     }
3395     else {
3396         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3397             dTARGET;
3398             SvUTF8_off(TARG);                           /* decontaminate */
3399             sv_setsv_nomg(TARG, sv);
3400             sv = TARG;
3401             SETs(sv);
3402         }
3403         s = (U8*)SvPV_force_nomg(sv, slen);
3404         if (*s) {
3405             if (IN_LOCALE_RUNTIME) {
3406                 TAINT;
3407                 SvTAINTED_on(sv);
3408                 *s = toUPPER_LC(*s);
3409             }
3410             else
3411                 *s = toUPPER(*s);
3412         }
3413     }
3414     SvSETMAGIC(sv);
3415     RETURN;
3416 }
3417
3418 PP(pp_lcfirst)
3419 {
3420     dSP;
3421     SV *sv = TOPs;
3422     register U8 *s;
3423     STRLEN slen;
3424
3425     SvGETMAGIC(sv);
3426     if (DO_UTF8(sv) &&
3427         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3428         UTF8_IS_START(*s)) {
3429         STRLEN ulen;
3430         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3431         U8 *tend;
3432         UV uv;
3433
3434         toLOWER_utf8(s, tmpbuf, &ulen);
3435         uv = utf8_to_uvchr(tmpbuf, 0);
3436         tend = uvchr_to_utf8(tmpbuf, uv);
3437
3438         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3439             dTARGET;
3440             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3441             if (slen > ulen)
3442                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3443             SvUTF8_on(TARG);
3444             SETs(TARG);
3445         }
3446         else {
3447             s = (U8*)SvPV_force_nomg(sv, slen);
3448             Copy(tmpbuf, s, ulen, U8);
3449         }
3450     }
3451     else {
3452         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3453             dTARGET;
3454             SvUTF8_off(TARG);                           /* decontaminate */
3455             sv_setsv_nomg(TARG, sv);
3456             sv = TARG;
3457             SETs(sv);
3458         }
3459         s = (U8*)SvPV_force_nomg(sv, slen);
3460         if (*s) {
3461             if (IN_LOCALE_RUNTIME) {
3462                 TAINT;
3463                 SvTAINTED_on(sv);
3464                 *s = toLOWER_LC(*s);
3465             }
3466             else
3467                 *s = toLOWER(*s);
3468         }
3469     }
3470     SvSETMAGIC(sv);
3471     RETURN;
3472 }
3473
3474 PP(pp_uc)
3475 {
3476     dSP;
3477     SV *sv = TOPs;
3478     register U8 *s;
3479     STRLEN len;
3480
3481     SvGETMAGIC(sv);
3482     if (DO_UTF8(sv)) {
3483         dTARGET;
3484         STRLEN ulen;
3485         register U8 *d;
3486         U8 *send;
3487         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3488
3489         s = (U8*)SvPV_nomg(sv,len);
3490         if (!len) {
3491             SvUTF8_off(TARG);                           /* decontaminate */
3492             sv_setpvn(TARG, "", 0);
3493             SETs(TARG);
3494         }
3495         else {
3496             STRLEN nchar = utf8_length(s, s + len);
3497
3498             (void)SvUPGRADE(TARG, SVt_PV);
3499             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3500             (void)SvPOK_only(TARG);
3501             d = (U8*)SvPVX(TARG);
3502             send = s + len;
3503             while (s < send) {
3504                 toUPPER_utf8(s, tmpbuf, &ulen);
3505                 Copy(tmpbuf, d, ulen, U8);
3506                 d += ulen;
3507                 s += UTF8SKIP(s);
3508             }
3509             *d = '\0';
3510             SvUTF8_on(TARG);
3511             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3512             SETs(TARG);
3513         }
3514     }
3515     else {
3516         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3517             dTARGET;
3518             SvUTF8_off(TARG);                           /* decontaminate */
3519             sv_setsv_nomg(TARG, sv);
3520             sv = TARG;
3521             SETs(sv);
3522         }
3523         s = (U8*)SvPV_force_nomg(sv, len);
3524         if (len) {
3525             register U8 *send = s + len;
3526
3527             if (IN_LOCALE_RUNTIME) {
3528                 TAINT;
3529                 SvTAINTED_on(sv);
3530                 for (; s < send; s++)
3531                     *s = toUPPER_LC(*s);
3532             }
3533             else {
3534                 for (; s < send; s++)
3535                     *s = toUPPER(*s);
3536             }
3537         }
3538     }
3539     SvSETMAGIC(sv);
3540     RETURN;
3541 }
3542
3543 PP(pp_lc)
3544 {
3545     dSP;
3546     SV *sv = TOPs;
3547     register U8 *s;
3548     STRLEN len;
3549
3550     SvGETMAGIC(sv);
3551     if (DO_UTF8(sv)) {
3552         dTARGET;
3553         STRLEN ulen;
3554         register U8 *d;
3555         U8 *send;
3556         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3557
3558         s = (U8*)SvPV_nomg(sv,len);
3559         if (!len) {
3560             SvUTF8_off(TARG);                           /* decontaminate */
3561             sv_setpvn(TARG, "", 0);
3562             SETs(TARG);
3563         }
3564         else {
3565             STRLEN nchar = utf8_length(s, s + len);
3566
3567             (void)SvUPGRADE(TARG, SVt_PV);
3568             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3569             (void)SvPOK_only(TARG);
3570             d = (U8*)SvPVX(TARG);
3571             send = s + len;
3572             while (s < send) {
3573                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3574 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3575                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3576                      /*
3577                       * Now if the sigma is NOT followed by
3578                       * /$ignorable_sequence$cased_letter/;
3579                       * and it IS preceded by
3580                       * /$cased_letter$ignorable_sequence/;
3581                       * where $ignorable_sequence is
3582                       * [\x{2010}\x{AD}\p{Mn}]*
3583                       * and $cased_letter is
3584                       * [\p{Ll}\p{Lo}\p{Lt}]
3585                       * then it should be mapped to 0x03C2,
3586                       * (GREEK SMALL LETTER FINAL SIGMA),
3587                       * instead of staying 0x03A3.
3588                       * See lib/unicore/SpecCase.txt.
3589                       */
3590                 }
3591                 Copy(tmpbuf, d, ulen, U8);
3592                 d += ulen;
3593                 s += UTF8SKIP(s);
3594             }
3595             *d = '\0';
3596             SvUTF8_on(TARG);
3597             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3598             SETs(TARG);
3599         }
3600     }
3601     else {
3602         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3603             dTARGET;
3604             SvUTF8_off(TARG);                           /* decontaminate */
3605             sv_setsv_nomg(TARG, sv);
3606             sv = TARG;
3607             SETs(sv);
3608         }
3609
3610         s = (U8*)SvPV_force_nomg(sv, len);
3611         if (len) {
3612             register U8 *send = s + len;
3613
3614             if (IN_LOCALE_RUNTIME) {
3615                 TAINT;
3616                 SvTAINTED_on(sv);
3617                 for (; s < send; s++)
3618                     *s = toLOWER_LC(*s);
3619             }
3620             else {
3621                 for (; s < send; s++)
3622                     *s = toLOWER(*s);
3623             }
3624         }
3625     }
3626     SvSETMAGIC(sv);
3627     RETURN;
3628 }
3629
3630 PP(pp_quotemeta)
3631 {
3632     dSP; dTARGET;
3633     SV *sv = TOPs;
3634     STRLEN len;
3635     register char *s = SvPV(sv,len);
3636     register char *d;
3637
3638     SvUTF8_off(TARG);                           /* decontaminate */
3639     if (len) {
3640         (void)SvUPGRADE(TARG, SVt_PV);
3641         SvGROW(TARG, (len * 2) + 1);
3642         d = SvPVX(TARG);
3643         if (DO_UTF8(sv)) {
3644             while (len) {
3645                 if (UTF8_IS_CONTINUED(*s)) {
3646                     STRLEN ulen = UTF8SKIP(s);
3647                     if (ulen > len)
3648                         ulen = len;
3649                     len -= ulen;
3650                     while (ulen--)
3651                         *d++ = *s++;
3652                 }
3653                 else {
3654                     if (!isALNUM(*s))
3655                         *d++ = '\\';
3656                     *d++ = *s++;
3657                     len--;
3658                 }
3659             }
3660             SvUTF8_on(TARG);
3661         }
3662         else {
3663             while (len--) {
3664                 if (!isALNUM(*s))
3665                     *d++ = '\\';
3666                 *d++ = *s++;
3667             }
3668         }
3669         *d = '\0';
3670         SvCUR_set(TARG, d - SvPVX(TARG));
3671         (void)SvPOK_only_UTF8(TARG);
3672     }
3673     else
3674         sv_setpvn(TARG, s, len);
3675     SETs(TARG);
3676     if (SvSMAGICAL(TARG))
3677         mg_set(TARG);
3678     RETURN;
3679 }
3680
3681 /* Arrays. */
3682
3683 PP(pp_aslice)
3684 {
3685     dSP; dMARK; dORIGMARK;
3686     register SV** svp;
3687     register AV* av = (AV*)POPs;
3688     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3689     I32 arybase = PL_curcop->cop_arybase;
3690     I32 elem;
3691
3692     if (SvTYPE(av) == SVt_PVAV) {
3693         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3694             I32 max = -1;
3695             for (svp = MARK + 1; svp <= SP; svp++) {
3696                 elem = SvIVx(*svp);
3697                 if (elem > max)
3698                     max = elem;
3699             }
3700             if (max > AvMAX(av))
3701                 av_extend(av, max);
3702         }
3703         while (++MARK <= SP) {
3704             elem = SvIVx(*MARK);
3705
3706             if (elem > 0)
3707                 elem -= arybase;
3708             svp = av_fetch(av, elem, lval);
3709             if (lval) {
3710                 if (!svp || *svp == &PL_sv_undef)
3711                     DIE(aTHX_ PL_no_aelem, elem);
3712                 if (PL_op->op_private & OPpLVAL_INTRO)
3713                     save_aelem(av, elem, svp);
3714             }
3715             *MARK = svp ? *svp : &PL_sv_undef;
3716         }
3717     }
3718     if (GIMME != G_ARRAY) {
3719         MARK = ORIGMARK;
3720         *++MARK = *SP;
3721         SP = MARK;
3722     }
3723     RETURN;
3724 }
3725
3726 /* Associative arrays. */
3727
3728 PP(pp_each)
3729 {
3730     dSP;
3731     HV *hash = (HV*)POPs;
3732     HE *entry;
3733     I32 gimme = GIMME_V;
3734
3735     PUTBACK;
3736     /* might clobber stack_sp */
3737     entry = hv_iternext(hash);
3738     SPAGAIN;
3739
3740     EXTEND(SP, 2);
3741     if (entry) {
3742         SV* sv = hv_iterkeysv(entry);
3743         PUSHs(sv);      /* won't clobber stack_sp */
3744         if (gimme == G_ARRAY) {
3745             SV *val;
3746             PUTBACK;
3747             /* might clobber stack_sp */
3748             val = hv_iterval(hash, entry);
3749             SPAGAIN;
3750             PUSHs(val);
3751         }
3752     }
3753     else if (gimme == G_SCALAR)
3754         RETPUSHUNDEF;
3755
3756     RETURN;
3757 }
3758
3759 PP(pp_values)
3760 {
3761     return do_kv();
3762 }
3763
3764 PP(pp_keys)
3765 {
3766     return do_kv();
3767 }
3768
3769 PP(pp_delete)
3770 {
3771     dSP;
3772     I32 gimme = GIMME_V;
3773     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3774     SV *sv;
3775     HV *hv;
3776
3777     if (PL_op->op_private & OPpSLICE) {
3778         dMARK; dORIGMARK;
3779         U32 hvtype;
3780         hv = (HV*)POPs;
3781         hvtype = SvTYPE(hv);
3782         if (hvtype == SVt_PVHV) {                       /* hash element */
3783             while (++MARK <= SP) {
3784                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3785                 *MARK = sv ? sv : &PL_sv_undef;
3786             }
3787         }
3788         else if (hvtype == SVt_PVAV) {                  /* array element */
3789             if (PL_op->op_flags & OPf_SPECIAL) {
3790                 while (++MARK <= SP) {
3791                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3792                     *MARK = sv ? sv : &PL_sv_undef;
3793                 }
3794             }
3795         }
3796         else
3797             DIE(aTHX_ "Not a HASH reference");
3798         if (discard)
3799             SP = ORIGMARK;
3800         else if (gimme == G_SCALAR) {
3801             MARK = ORIGMARK;
3802             if (SP > MARK)
3803                 *++MARK = *SP;
3804             else
3805                 *++MARK = &PL_sv_undef;
3806             SP = MARK;
3807         }
3808     }
3809     else {
3810         SV *keysv = POPs;
3811         hv = (HV*)POPs;
3812         if (SvTYPE(hv) == SVt_PVHV)
3813             sv = hv_delete_ent(hv, keysv, discard, 0);
3814         else if (SvTYPE(hv) == SVt_PVAV) {
3815             if (PL_op->op_flags & OPf_SPECIAL)
3816                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3817             else
3818                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3819         }
3820         else
3821             DIE(aTHX_ "Not a HASH reference");
3822         if (!sv)
3823             sv = &PL_sv_undef;
3824         if (!discard)
3825             PUSHs(sv);
3826     }
3827     RETURN;
3828 }
3829
3830 PP(pp_exists)
3831 {
3832     dSP;
3833     SV *tmpsv;
3834     HV *hv;
3835
3836     if (PL_op->op_private & OPpEXISTS_SUB) {
3837         GV *gv;
3838         CV *cv;
3839         SV *sv = POPs;
3840         cv = sv_2cv(sv, &hv, &gv, FALSE);
3841         if (cv)
3842             RETPUSHYES;
3843         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3844             RETPUSHYES;
3845         RETPUSHNO;
3846     }
3847     tmpsv = POPs;
3848     hv = (HV*)POPs;
3849     if (SvTYPE(hv) == SVt_PVHV) {
3850         if (hv_exists_ent(hv, tmpsv, 0))
3851             RETPUSHYES;
3852     }
3853     else if (SvTYPE(hv) == SVt_PVAV) {
3854         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3855             if (av_exists((AV*)hv, SvIV(tmpsv)))
3856                 RETPUSHYES;
3857         }
3858     }
3859     else {
3860         DIE(aTHX_ "Not a HASH reference");
3861     }
3862     RETPUSHNO;
3863 }
3864
3865 PP(pp_hslice)
3866 {
3867     dSP; dMARK; dORIGMARK;
3868     register HV *hv = (HV*)POPs;
3869     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3870     bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3871     bool other_magic = FALSE;
3872
3873     if (localizing) {
3874         MAGIC *mg;
3875         HV *stash;
3876
3877         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3878             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3879              /* Try to preserve the existenceness of a tied hash
3880               * element by using EXISTS and DELETE if possible.
3881               * Fallback to FETCH and STORE otherwise */
3882              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3883              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3884              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3885     }
3886
3887     while (++MARK <= SP) {
3888         SV *keysv = *MARK;
3889         SV **svp;
3890         HE *he;
3891         bool preeminent = FALSE;
3892
3893         if (localizing) {
3894             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3895                 hv_exists_ent(hv, keysv, 0);
3896         }
3897
3898         he = hv_fetch_ent(hv, keysv, lval, 0);
3899         svp = he ? &HeVAL(he) : 0;
3900
3901         if (lval) {
3902             if (!svp || *svp == &PL_sv_undef) {
3903                 STRLEN n_a;
3904                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3905             }
3906             if (localizing) {
3907                 if (preeminent)
3908                     save_helem(hv, keysv, svp);
3909                 else {
3910                     STRLEN keylen;
3911                     char *key = SvPV(keysv, keylen);
3912                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
3913                 }
3914             }
3915         }
3916         *MARK = svp ? *svp : &PL_sv_undef;
3917     }
3918     if (GIMME != G_ARRAY) {
3919         MARK = ORIGMARK;
3920         *++MARK = *SP;
3921         SP = MARK;
3922     }
3923     RETURN;
3924 }
3925
3926 /* List operators. */
3927
3928 PP(pp_list)
3929 {
3930     dSP; dMARK;
3931     if (GIMME != G_ARRAY) {
3932         if (++MARK <= SP)
3933             *MARK = *SP;                /* unwanted list, return last item */
3934         else
3935             *MARK = &PL_sv_undef;
3936         SP = MARK;
3937     }
3938     RETURN;
3939 }
3940
3941 PP(pp_lslice)
3942 {
3943     dSP;
3944     SV **lastrelem = PL_stack_sp;
3945     SV **lastlelem = PL_stack_base + POPMARK;
3946     SV **firstlelem = PL_stack_base + POPMARK + 1;
3947     register SV **firstrelem = lastlelem + 1;
3948     I32 arybase = PL_curcop->cop_arybase;
3949     I32 lval = PL_op->op_flags & OPf_MOD;
3950     I32 is_something_there = lval;
3951
3952     register I32 max = lastrelem - lastlelem;
3953     register SV **lelem;
3954     register I32 ix;
3955
3956     if (GIMME != G_ARRAY) {
3957         ix = SvIVx(*lastlelem);
3958         if (ix < 0)
3959             ix += max;
3960         else
3961             ix -= arybase;
3962         if (ix < 0 || ix >= max)
3963             *firstlelem = &PL_sv_undef;
3964         else
3965             *firstlelem = firstrelem[ix];
3966         SP = firstlelem;
3967         RETURN;
3968     }
3969
3970     if (max == 0) {
3971         SP = firstlelem - 1;
3972         RETURN;
3973     }
3974
3975     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3976         ix = SvIVx(*lelem);
3977         if (ix < 0)
3978             ix += max;
3979         else
3980             ix -= arybase;
3981         if (ix < 0 || ix >= max)
3982             *lelem = &PL_sv_undef;
3983         else {
3984             is_something_there = TRUE;
3985             if (!(*lelem = firstrelem[ix]))
3986                 *lelem = &PL_sv_undef;
3987         }
3988     }
3989     if (is_something_there)
3990         SP = lastlelem;
3991     else
3992         SP = firstlelem - 1;
3993     RETURN;
3994 }
3995
3996 PP(pp_anonlist)
3997 {
3998     dSP; dMARK; dORIGMARK;
3999     I32 items = SP - MARK;
4000     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4001     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4002     XPUSHs(av);
4003     RETURN;
4004 }
4005
4006 PP(pp_anonhash)
4007 {
4008     dSP; dMARK; dORIGMARK;
4009     HV* hv = (HV*)sv_2mortal((SV*)newHV());
4010
4011     while (MARK < SP) {
4012         SV* key = *++MARK;
4013         SV *val = NEWSV(46, 0);
4014         if (MARK < SP)
4015             sv_setsv(val, *++MARK);
4016         else if (ckWARN(WARN_MISC))
4017             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4018         (void)hv_store_ent(hv,key,val,0);
4019     }
4020     SP = ORIGMARK;
4021     XPUSHs((SV*)hv);
4022     RETURN;
4023 }
4024
4025 PP(pp_splice)
4026 {
4027     dSP; dMARK; dORIGMARK;
4028     register AV *ary = (AV*)*++MARK;
4029     register SV **src;
4030     register SV **dst;
4031     register I32 i;
4032     register I32 offset;
4033     register I32 length;
4034     I32 newlen;
4035     I32 after;
4036     I32 diff;
4037     SV **tmparyval = 0;
4038     MAGIC *mg;
4039
4040     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4041         *MARK-- = SvTIED_obj((SV*)ary, mg);
4042         PUSHMARK(MARK);
4043         PUTBACK;
4044         ENTER;
4045         call_method("SPLICE",GIMME_V);
4046         LEAVE;
4047         SPAGAIN;
4048         RETURN;
4049     }
4050
4051     SP++;
4052
4053     if (++MARK < SP) {
4054         offset = i = SvIVx(*MARK);
4055         if (offset < 0)
4056             offset += AvFILLp(ary) + 1;
4057         else
4058             offset -= PL_curcop->cop_arybase;
4059         if (offset < 0)
4060             DIE(aTHX_ PL_no_aelem, i);
4061         if (++MARK < SP) {
4062             length = SvIVx(*MARK++);
4063             if (length < 0) {
4064                 length += AvFILLp(ary) - offset + 1;
4065                 if (length < 0)
4066                     length = 0;
4067             }
4068         }
4069         else
4070             length = AvMAX(ary) + 1;            /* close enough to infinity */
4071     }
4072     else {
4073         offset = 0;
4074         length = AvMAX(ary) + 1;
4075     }
4076     if (offset > AvFILLp(ary) + 1) {
4077         if (ckWARN(WARN_MISC))
4078             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4079         offset = AvFILLp(ary) + 1;
4080     }
4081     after = AvFILLp(ary) + 1 - (offset + length);
4082     if (after < 0) {                            /* not that much array */
4083         length += after;                        /* offset+length now in array */
4084         after = 0;
4085         if (!AvALLOC(ary))
4086             av_extend(ary, 0);
4087     }
4088
4089     /* At this point, MARK .. SP-1 is our new LIST */
4090
4091     newlen = SP - MARK;
4092     diff = newlen - length;
4093     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4094         av_reify(ary);
4095
4096     if (diff < 0) {                             /* shrinking the area */
4097         if (newlen) {
4098             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4099             Copy(MARK, tmparyval, newlen, SV*);
4100         }
4101
4102         MARK = ORIGMARK + 1;
4103         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4104             MEXTEND(MARK, length);
4105             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4106             if (AvREAL(ary)) {
4107                 EXTEND_MORTAL(length);
4108                 for (i = length, dst = MARK; i; i--) {
4109                     sv_2mortal(*dst);   /* free them eventualy */
4110                     dst++;
4111                 }
4112             }
4113             MARK += length - 1;
4114         }
4115         else {
4116             *MARK = AvARRAY(ary)[offset+length-1];
4117             if (AvREAL(ary)) {
4118                 sv_2mortal(*MARK);
4119                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4120                     SvREFCNT_dec(*dst++);       /* free them now */
4121             }
4122         }
4123         AvFILLp(ary) += diff;
4124
4125         /* pull up or down? */
4126
4127         if (offset < after) {                   /* easier to pull up */
4128             if (offset) {                       /* esp. if nothing to pull */
4129                 src = &AvARRAY(ary)[offset-1];
4130                 dst = src - diff;               /* diff is negative */
4131                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4132                     *dst-- = *src--;
4133             }
4134             dst = AvARRAY(ary);
4135             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4136             AvMAX(ary) += diff;
4137         }
4138         else {
4139             if (after) {                        /* anything to pull down? */
4140                 src = AvARRAY(ary) + offset + length;
4141                 dst = src + diff;               /* diff is negative */
4142                 Move(src, dst, after, SV*);
4143             }
4144             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4145                                                 /* avoid later double free */
4146         }
4147         i = -diff;
4148         while (i)
4149             dst[--i] = &PL_sv_undef;
4150
4151         if (newlen) {
4152             for (src = tmparyval, dst = AvARRAY(ary) + offset;
4153               newlen; newlen--) {
4154                 *dst = NEWSV(46, 0);
4155                 sv_setsv(*dst++, *src++);
4156             }
4157             Safefree(tmparyval);
4158         }
4159     }
4160     else {                                      /* no, expanding (or same) */
4161         if (length) {
4162             New(452, tmparyval, length, SV*);   /* so remember deletion */
4163             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4164         }
4165
4166         if (diff > 0) {                         /* expanding */
4167
4168             /* push up or down? */
4169
4170             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4171                 if (offset) {
4172                     src = AvARRAY(ary);
4173                     dst = src - diff;
4174                     Move(src, dst, offset, SV*);
4175                 }
4176                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4177                 AvMAX(ary) += diff;
4178                 AvFILLp(ary) += diff;
4179             }
4180             else {
4181                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4182                     av_extend(ary, AvFILLp(ary) + diff);
4183                 AvFILLp(ary) += diff;
4184
4185                 if (after) {
4186                     dst = AvARRAY(ary) + AvFILLp(ary);
4187                     src = dst - diff;
4188                     for (i = after; i; i--) {
4189                         *dst-- = *src--;
4190                     }
4191                 }
4192             }
4193         }
4194
4195         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4196             *dst = NEWSV(46, 0);
4197             sv_setsv(*dst++, *src++);
4198         }
4199         MARK = ORIGMARK + 1;
4200         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4201             if (length) {
4202                 Copy(tmparyval, MARK, length, SV*);
4203                 if (AvREAL(ary)) {
4204                     EXTEND_MORTAL(length);
4205                     for (i = length, dst = MARK; i; i--) {
4206                         sv_2mortal(*dst);       /* free them eventualy */
4207                         dst++;
4208                     }
4209                 }
4210                 Safefree(tmparyval);
4211             }
4212             MARK += length - 1;
4213         }
4214         else if (length--) {
4215             *MARK = tmparyval[length];
4216             if (AvREAL(ary)) {
4217                 sv_2mortal(*MARK);
4218                 while (length-- > 0)
4219                     SvREFCNT_dec(tmparyval[length]);
4220             }
4221             Safefree(tmparyval);
4222         }
4223         else
4224             *MARK = &PL_sv_undef;
4225     }
4226     SP = MARK;
4227     RETURN;
4228 }
4229
4230 PP(pp_push)
4231 {
4232     dSP; dMARK; dORIGMARK; dTARGET;
4233     register AV *ary = (AV*)*++MARK;
4234     register SV *sv = &PL_sv_undef;
4235     MAGIC *mg;
4236
4237     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4238         *MARK-- = SvTIED_obj((SV*)ary, mg);
4239         PUSHMARK(MARK);
4240         PUTBACK;
4241         ENTER;
4242         call_method("PUSH",G_SCALAR|G_DISCARD);
4243         LEAVE;
4244         SPAGAIN;
4245     }
4246     else {
4247         /* Why no pre-extend of ary here ? */
4248         for (++MARK; MARK <= SP; MARK++) {
4249             sv = NEWSV(51, 0);
4250             if (*MARK)
4251                 sv_setsv(sv, *MARK);
4252             av_push(ary, sv);
4253         }
4254     }
4255     SP = ORIGMARK;
4256     PUSHi( AvFILL(ary) + 1 );
4257     RETURN;
4258 }
4259
4260 PP(pp_pop)
4261 {
4262     dSP;
4263     AV *av = (AV*)POPs;
4264     SV *sv = av_pop(av);
4265     if (AvREAL(av))
4266         (void)sv_2mortal(sv);
4267     PUSHs(sv);
4268     RETURN;
4269 }
4270
4271 PP(pp_shift)
4272 {
4273     dSP;
4274     AV *av = (AV*)POPs;
4275     SV *sv = av_shift(av);
4276     EXTEND(SP, 1);
4277     if (!sv)
4278         RETPUSHUNDEF;
4279     if (AvREAL(av))
4280         (void)sv_2mortal(sv);
4281     PUSHs(sv);
4282     RETURN;
4283 }
4284
4285 PP(pp_unshift)
4286 {
4287     dSP; dMARK; dORIGMARK; dTARGET;
4288     register AV *ary = (AV*)*++MARK;
4289     register SV *sv;
4290     register I32 i = 0;
4291     MAGIC *mg;
4292
4293     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4294         *MARK-- = SvTIED_obj((SV*)ary, mg);
4295         PUSHMARK(MARK);
4296         PUTBACK;
4297         ENTER;
4298         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4299         LEAVE;
4300         SPAGAIN;
4301     }
4302     else {
4303         av_unshift(ary, SP - MARK);
4304         while (MARK < SP) {
4305             sv = NEWSV(27, 0);
4306             sv_setsv(sv, *++MARK);
4307             (void)av_store(ary, i++, sv);
4308         }
4309     }
4310     SP = ORIGMARK;
4311     PUSHi( AvFILL(ary) + 1 );
4312     RETURN;
4313 }
4314
4315 PP(pp_reverse)
4316 {
4317     dSP; dMARK;
4318     register SV *tmp;
4319     SV **oldsp = SP;
4320
4321     if (GIMME == G_ARRAY) {
4322         MARK++;
4323         while (MARK < SP) {
4324             tmp = *MARK;
4325             *MARK++ = *SP;
4326             *SP-- = tmp;
4327         }
4328         /* safe as long as stack cannot get extended in the above */
4329         SP = oldsp;
4330     }
4331     else {
4332         register char *up;
4333         register char *down;
4334         register I32 tmp;
4335         dTARGET;
4336         STRLEN len;
4337         I32 padoff_du;
4338
4339         SvUTF8_off(TARG);                               /* decontaminate */
4340         if (SP - MARK > 1)
4341             do_join(TARG, &PL_sv_no, MARK, SP);
4342         else
4343             sv_setsv(TARG, (SP > MARK)
4344                     ? *SP
4345                     : (padoff_du = find_rundefsvoffset(),
4346                         (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4347                         ? DEFSV : PAD_SVl(padoff_du)));
4348         up = SvPV_force(TARG, len);
4349         if (len > 1) {
4350             if (DO_UTF8(TARG)) {        /* first reverse each character */
4351                 U8* s = (U8*)SvPVX(TARG);
4352                 U8* send = (U8*)(s + len);
4353                 while (s < send) {
4354                     if (UTF8_IS_INVARIANT(*s)) {
4355                         s++;
4356                         continue;
4357                     }
4358                     else {
4359                         if (!utf8_to_uvchr(s, 0))
4360                             break;
4361                         up = (char*)s;
4362                         s += UTF8SKIP(s);
4363                         down = (char*)(s - 1);
4364                         /* reverse this character */
4365                         while (down > up) {
4366                             tmp = *up;
4367                             *up++ = *down;
4368                             *down-- = (char)tmp;
4369                         }
4370                     }
4371                 }
4372                 up = SvPVX(TARG);
4373             }
4374             down = SvPVX(TARG) + len - 1;
4375             while (down > up) {
4376                 tmp = *up;
4377                 *up++ = *down;
4378                 *down-- = (char)tmp;
4379             }
4380             (void)SvPOK_only_UTF8(TARG);
4381         }
4382         SP = MARK + 1;
4383         SETTARG;
4384     }
4385     RETURN;
4386 }
4387
4388 PP(pp_split)
4389 {
4390     dSP; dTARG;
4391     AV *ary;
4392     register IV limit = POPi;                   /* note, negative is forever */
4393     SV *sv = POPs;
4394     STRLEN len;
4395     register char *s = SvPV(sv, len);
4396     bool do_utf8 = DO_UTF8(sv);
4397     char *strend = s + len;
4398     register PMOP *pm;
4399     register REGEXP *rx;
4400     register SV *dstr;
4401     register char *m;
4402     I32 iters = 0;
4403     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4404     I32 maxiters = slen + 10;
4405     I32 i;
4406     char *orig;
4407     I32 origlimit = limit;
4408     I32 realarray = 0;
4409     I32 base;
4410     AV *oldstack = PL_curstack;
4411     I32 gimme = GIMME_V;
4412     I32 oldsave = PL_savestack_ix;
4413     I32 make_mortal = 1;
4414     MAGIC *mg = (MAGIC *) NULL;
4415
4416 #ifdef DEBUGGING
4417     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4418 #else
4419     pm = (PMOP*)POPs;
4420 #endif
4421     if (!pm || !s)
4422         DIE(aTHX_ "panic: pp_split");
4423     rx = PM_GETRE(pm);
4424
4425     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4426              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4427
4428     RX_MATCH_UTF8_set(rx, do_utf8);
4429
4430     if (pm->op_pmreplroot) {
4431 #ifdef USE_ITHREADS
4432         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4433 #else
4434         ary = GvAVn((GV*)pm->op_pmreplroot);
4435 #endif
4436     }
4437     else if (gimme != G_ARRAY)
4438         ary = GvAVn(PL_defgv);
4439     else
4440         ary = Nullav;
4441     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4442         realarray = 1;
4443         PUTBACK;
4444         av_extend(ary,0);
4445         av_clear(ary);
4446         SPAGAIN;
4447         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4448             PUSHMARK(SP);
4449             XPUSHs(SvTIED_obj((SV*)ary, mg));
4450         }
4451         else {
4452             if (!AvREAL(ary)) {
4453                 AvREAL_on(ary);
4454                 AvREIFY_off(ary);
4455                 for (i = AvFILLp(ary); i >= 0; i--)
4456                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4457             }
4458             /* temporarily switch stacks */
4459             SWITCHSTACK(PL_curstack, ary);
4460             PL_curstackinfo->si_stack = ary;
4461             make_mortal = 0;
4462         }
4463     }
4464     base = SP - PL_stack_base;
4465     orig = s;
4466     if (pm->op_pmflags & PMf_SKIPWHITE) {
4467         if (pm->op_pmflags & PMf_LOCALE) {
4468             while (isSPACE_LC(*s))
4469                 s++;
4470         }
4471         else {
4472             while (isSPACE(*s))
4473                 s++;
4474         }
4475     }
4476     if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4477         SAVEINT(PL_multiline);
4478         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4479     }
4480
4481     if (!limit)
4482         limit = maxiters + 2;
4483     if (pm->op_pmflags & PMf_WHITE) {
4484         while (--limit) {
4485             m = s;
4486             while (m < strend &&
4487                    !((pm->op_pmflags & PMf_LOCALE)
4488                      ? isSPACE_LC(*m) : isSPACE(*m)))
4489                 ++m;
4490             if (m >= strend)
4491                 break;
4492
4493             dstr = NEWSV(30, m-s);
4494             sv_setpvn(dstr, s, m-s);
4495             if (make_mortal)
4496                 sv_2mortal(dstr);
4497             if (do_utf8)
4498                 (void)SvUTF8_on(dstr);
4499             XPUSHs(dstr);
4500
4501             s = m + 1;
4502             while (s < strend &&
4503                    ((pm->op_pmflags & PMf_LOCALE)
4504                     ? isSPACE_LC(*s) : isSPACE(*s)))
4505                 ++s;
4506         }
4507     }
4508     else if (strEQ("^", rx->precomp)) {
4509         while (--limit) {
4510             /*SUPPRESS 530*/
4511             for (m = s; m < strend && *m != '\n'; m++) ;
4512             m++;
4513             if (m >= strend)
4514                 break;
4515             dstr = NEWSV(30, m-s);
4516             sv_setpvn(dstr, s, m-s);
4517             if (make_mortal)
4518                 sv_2mortal(dstr);
4519             if (do_utf8)
4520                 (void)SvUTF8_on(dstr);
4521             XPUSHs(dstr);
4522             s = m;
4523         }
4524     }
4525     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4526              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4527              && (rx->reganch & ROPT_CHECK_ALL)
4528              && !(rx->reganch & ROPT_ANCH)) {
4529         int tail = (rx->reganch & RE_INTUIT_TAIL);
4530         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4531
4532         len = rx->minlen;
4533         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4534             STRLEN n_a;
4535             char c = *SvPV(csv, n_a);
4536             while (--limit) {
4537                 /*SUPPRESS 530*/
4538                 for (m = s; m < strend && *m != c; m++) ;
4539                 if (m >= strend)
4540                     break;
4541                 dstr = NEWSV(30, m-s);
4542                 sv_setpvn(dstr, s, m-s);
4543                 if (make_mortal)
4544                     sv_2mortal(dstr);
4545                 if (do_utf8)
4546                     (void)SvUTF8_on(dstr);
4547                 XPUSHs(dstr);
4548                 /* The rx->minlen is in characters but we want to step
4549                  * s ahead by bytes. */
4550                 if (do_utf8)
4551                     s = (char*)utf8_hop((U8*)m, len);
4552                 else
4553                     s = m + len; /* Fake \n at the end */
4554             }
4555         }
4556         else {
4557 #ifndef lint
4558             while (s < strend && --limit &&
4559               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4560                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4561 #endif
4562             {
4563                 dstr = NEWSV(31, m-s);
4564                 sv_setpvn(dstr, s, m-s);
4565                 if (make_mortal)
4566                     sv_2mortal(dstr);
4567                 if (do_utf8)
4568                     (void)SvUTF8_on(dstr);
4569                 XPUSHs(dstr);
4570                 /* The rx->minlen is in characters but we want to step
4571                  * s ahead by bytes. */
4572                 if (do_utf8)
4573                     s = (char*)utf8_hop((U8*)m, len);
4574                 else
4575                     s = m + len; /* Fake \n at the end */
4576             }
4577         }
4578     }
4579     else {
4580         maxiters += slen * rx->nparens;
4581         while (s < strend && --limit)
4582         {
4583             PUTBACK;
4584             i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4585             SPAGAIN;
4586             if (i == 0)
4587                 break;
4588             TAINT_IF(RX_MATCH_TAINTED(rx));
4589             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4590                 m = s;
4591                 s = orig;
4592                 orig = rx->subbeg;
4593                 s = orig + (m - s);
4594                 strend = s + (strend - m);
4595             }
4596             m = rx->startp[0] + orig;
4597             dstr = NEWSV(32, m-s);
4598             sv_setpvn(dstr, s, m-s);
4599             if (make_mortal)
4600                 sv_2mortal(dstr);
4601             if (do_utf8)
4602                 (void)SvUTF8_on(dstr);
4603             XPUSHs(dstr);
4604             if (rx->nparens) {
4605                 for (i = 1; i <= (I32)rx->nparens; i++) {
4606                     s = rx->startp[i] + orig;
4607                     m = rx->endp[i] + orig;
4608
4609                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4610                        parens that didn't match -- they should be set to
4611                        undef, not the empty string */
4612                     if (m >= orig && s >= orig) {
4613                         dstr = NEWSV(33, m-s);
4614                         sv_setpvn(dstr, s, m-s);
4615                     }
4616                     else
4617                         dstr = &PL_sv_undef;  /* undef, not "" */
4618                     if (make_mortal)
4619                         sv_2mortal(dstr);
4620                     if (do_utf8)
4621                         (void)SvUTF8_on(dstr);
4622                     XPUSHs(dstr);
4623                 }
4624             }
4625             s = rx->endp[0] + orig;
4626         }
4627     }
4628
4629     LEAVE_SCOPE(oldsave);
4630     iters = (SP - PL_stack_base) - base;
4631     if (iters > maxiters)
4632         DIE(aTHX_ "Split loop");
4633
4634     /* keep field after final delim? */
4635     if (s < strend || (iters && origlimit)) {
4636         STRLEN l = strend - s;
4637         dstr = NEWSV(34, l);
4638         sv_setpvn(dstr, s, l);
4639         if (make_mortal)
4640             sv_2mortal(dstr);
4641         if (do_utf8)
4642             (void)SvUTF8_on(dstr);
4643         XPUSHs(dstr);
4644         iters++;
4645     }
4646     else if (!origlimit) {
4647         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4648             if (TOPs && !make_mortal)
4649                 sv_2mortal(TOPs);
4650             iters--;
4651             *SP-- = &PL_sv_undef;
4652         }
4653     }
4654
4655     if (realarray) {
4656         if (!mg) {
4657             SWITCHSTACK(ary, oldstack);
4658             PL_curstackinfo->si_stack = oldstack;
4659             if (SvSMAGICAL(ary)) {
4660                 PUTBACK;
4661                 mg_set((SV*)ary);
4662                 SPAGAIN;
4663             }
4664             if (gimme == G_ARRAY) {
4665                 EXTEND(SP, iters);
4666                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4667                 SP += iters;
4668                 RETURN;
4669             }
4670         }
4671         else {
4672             PUTBACK;
4673             ENTER;
4674             call_method("PUSH",G_SCALAR|G_DISCARD);
4675             LEAVE;
4676             SPAGAIN;
4677             if (gimme == G_ARRAY) {
4678                 /* EXTEND should not be needed - we just popped them */
4679                 EXTEND(SP, iters);
4680                 for (i=0; i < iters; i++) {
4681                     SV **svp = av_fetch(ary, i, FALSE);
4682                     PUSHs((svp) ? *svp : &PL_sv_undef);
4683                 }
4684                 RETURN;
4685             }
4686         }
4687     }
4688     else {
4689         if (gimme == G_ARRAY)
4690             RETURN;
4691     }
4692
4693     GETTARGET;
4694     PUSHi(iters);
4695     RETURN;
4696 }
4697
4698 PP(pp_lock)
4699 {
4700     dSP;
4701     dTOPss;
4702     SV *retsv = sv;
4703     SvLOCK(sv);
4704     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4705         || SvTYPE(retsv) == SVt_PVCV) {
4706         retsv = refto(retsv);
4707     }
4708     SETs(retsv);
4709     RETURN;
4710 }
4711
4712 PP(pp_threadsv)
4713 {
4714     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4715 }