pp.c

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