pp.c

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