pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (c) 1991-1999, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "It's a big house this, and very peculiar.  Always a bit more to discover,
  12  * and no knowing what you'll find around a corner.  And Elves, sir!" --Samwise
  13  */
  14
  15 #include "EXTERN.h"
  16 #define PERL_IN_PP_C
  17 #include "perl.h"
  18
  19 /*
  20  * The compiler on Concurrent CX/UX systems has a subtle bug which only
  21  * seems to show up when compiling pp.c - it generates the wrong double
  22  * precision constant value for (double)UV_MAX when used inline in the body
  23  * of the code below, so this makes a static variable up front (which the
  24  * compiler seems to get correct) and uses it in place of UV_MAX below.
  25  */
  26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
  27 static double UV_MAX_cxux = ((double)UV_MAX);
  28 #endif
  29
  30 /*
  31  * Offset for integer pack/unpack.
  32  *
  33  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  34  * which for now are all Crays, pack and unpack have to play games.
  35  */
  36
  37 /*
  38  * These values are required for portability of pack() output.
  39  * If they're not right on your machine, then pack() and unpack()
  40  * wouldn't work right anyway; you'll need to apply the Cray hack.
  41  * (I'd like to check them with #if, but you can't use sizeof() in
  42  * the preprocessor.)  --???
  43  */
  44 /*
  45     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
  46     defines are now in config.h.  --Andy Dougherty  April 1998
  47  */
  48 #define SIZE16 2
  49 #define SIZE32 4
  50
  51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
  52    --jhi Feb 1999 */
  53
  54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
  55 #   define PERL_NATINT_PACK
  56 #endif
  57
  58 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
  59 #  if BYTEORDER == 0x12345678
  60 #    define OFF16(p)    (char*)(p)
  61 #    define OFF32(p)    (char*)(p)
  62 #  else
  63 #    if BYTEORDER == 0x87654321
  64 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
  65 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
  66 #    else
  67        }}}} bad cray byte order
  68 #    endif
  69 #  endif
  70 #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
  71 #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
  72 #  define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
  73 #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
  74 #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
  75 #else
  76 #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
  77 #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
  78 #  define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
  79 #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
  80 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
  81 #endif
  82
  83 /* variations on pp_null */
  84
  85 #ifdef I_UNISTD
  86 #include <unistd.h>
  87 #endif
  88
  89 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  90    it, since pid_t is an integral type.
  91    --AD  2/20/1998
  92 */
  93 #ifdef NEED_GETPID_PROTO
  94 extern Pid_t getpid (void);
  95 #endif
  96
  97 PP(pp_stub)
  98 {
  99     djSP;
 100     if (GIMME_V == G_SCALAR)
 101         XPUSHs(&PL_sv_undef);
 102     RETURN;
 103 }
 104
 105 PP(pp_scalar)
 106 {
 107     return NORMAL;
 108 }
 109
 110 /* Pushy stuff. */
 111
 112 PP(pp_padav)
 113 {
 114     djSP; dTARGET;
 115     if (PL_op->op_private & OPpLVAL_INTRO)
 116         SAVECLEARSV(PL_curpad[PL_op->op_targ]);
 117     EXTEND(SP, 1);
 118     if (PL_op->op_flags & OPf_REF) {
 119         PUSHs(TARG);
 120         RETURN;
 121     }
 122     if (GIMME == G_ARRAY) {
 123         I32 maxarg = AvFILL((AV*)TARG) + 1;
 124         EXTEND(SP, maxarg);
 125         if (SvMAGICAL(TARG)) {
 126             U32 i;
 127             for (i=0; i < maxarg; i++) {
 128                 SV **svp = av_fetch((AV*)TARG, i, FALSE);
 129                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 130             }
 131         }
 132         else {
 133             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
 134         }
 135         SP += maxarg;
 136     }
 137     else {
 138         SV* sv = sv_newmortal();
 139         I32 maxarg = AvFILL((AV*)TARG) + 1;
 140         sv_setiv(sv, maxarg);
 141         PUSHs(sv);
 142     }
 143     RETURN;
 144 }
 145
 146 PP(pp_padhv)
 147 {
 148     djSP; dTARGET;
 149     I32 gimme;
 150
 151     XPUSHs(TARG);
 152     if (PL_op->op_private & OPpLVAL_INTRO)
 153         SAVECLEARSV(PL_curpad[PL_op->op_targ]);
 154     if (PL_op->op_flags & OPf_REF)
 155         RETURN;
 156     gimme = GIMME_V;
 157     if (gimme == G_ARRAY) {
 158         RETURNOP(do_kv());
 159     }
 160     else if (gimme == G_SCALAR) {
 161         SV* sv = sv_newmortal();
 162         if (HvFILL((HV*)TARG))
 163             Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
 164                       (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
 165         else
 166             sv_setiv(sv, 0);
 167         SETs(sv);
 168     }
 169     RETURN;
 170 }
 171
 172 PP(pp_padany)
 173 {
 174     DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
 175 }
 176
 177 /* Translations. */
 178
 179 PP(pp_rv2gv)
 180 {
 181     djSP; dTOPss;
 182
 183     if (SvROK(sv)) {
 184       wasref:
 185         tryAMAGICunDEREF(to_gv);
 186
 187         sv = SvRV(sv);
 188         if (SvTYPE(sv) == SVt_PVIO) {
 189             GV *gv = (GV*) sv_newmortal();
 190             gv_init(gv, 0, "", 0, 0);
 191             GvIOp(gv) = (IO *)sv;
 192             (void)SvREFCNT_inc(sv);
 193             sv = (SV*) gv;
 194         }
 195         else if (SvTYPE(sv) != SVt_PVGV)
 196             DIE(aTHX_ "Not a GLOB reference");
 197     }
 198     else {
 199         if (SvTYPE(sv) != SVt_PVGV) {
 200             char *sym;
 201             STRLEN n_a;
 202
 203             if (SvGMAGICAL(sv)) {
 204                 mg_get(sv);
 205                 if (SvROK(sv))
 206                     goto wasref;
 207             }
 208             if (!SvOK(sv)) {
 209                 /* If this is a 'my' scalar and flag is set then vivify
 210                  * NI-S 1999/05/07
 211                  */
 212                 if (PL_op->op_private & OPpDEREF) {
 213                     GV *gv = (GV *) newSV(0);
 214                     STRLEN len = 0;
 215                     char *name = "";
 216                     if (cUNOP->op_first->op_type == OP_PADSV) {
 217                         SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
 218                         name = SvPV(padname,len);
 219                     }
 220                     gv_init(gv, PL_curcop->cop_stash, name, len, 0);
 221                     sv_upgrade(sv, SVt_RV);
 222                     SvRV(sv) = (SV *) gv;
 223                     SvROK_on(sv);
 224                     SvSETMAGIC(sv);
 225                     goto wasref;
 226                 }
 227                 if (PL_op->op_flags & OPf_REF ||
 228                     PL_op->op_private & HINT_STRICT_REFS)
 229                     DIE(aTHX_ PL_no_usym, "a symbol");
 230                 if (ckWARN(WARN_UNINITIALIZED))
 231                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
 232                 RETSETUNDEF;
 233             }
 234             sym = SvPV(sv, n_a);
 235             if ((PL_op->op_flags & OPf_SPECIAL) &&
 236                 !(PL_op->op_flags & OPf_MOD))
 237             {
 238                 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
 239                 if (!sv)
 240                     RETSETUNDEF;
 241             }
 242             else {
 243                 if (PL_op->op_private & HINT_STRICT_REFS)
 244                     DIE(aTHX_ PL_no_symref, sym, "a symbol");
 245                 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
 246             }
 247         }
 248     }
 249     if (PL_op->op_private & OPpLVAL_INTRO)
 250         save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
 251     SETs(sv);
 252     RETURN;
 253 }
 254
 255 PP(pp_rv2sv)
 256 {
 257     djSP; dTOPss;
 258
 259     if (SvROK(sv)) {
 260       wasref:
 261         tryAMAGICunDEREF(to_sv);
 262
 263         sv = SvRV(sv);
 264         switch (SvTYPE(sv)) {
 265         case SVt_PVAV:
 266         case SVt_PVHV:
 267         case SVt_PVCV:
 268             DIE(aTHX_ "Not a SCALAR reference");
 269         }
 270     }
 271     else {
 272         GV *gv = (GV*)sv;
 273         char *sym;
 274         STRLEN n_a;
 275
 276         if (SvTYPE(gv) != SVt_PVGV) {
 277             if (SvGMAGICAL(sv)) {
 278                 mg_get(sv);
 279                 if (SvROK(sv))
 280                     goto wasref;
 281             }
 282             if (!SvOK(sv)) {
 283                 if (PL_op->op_flags & OPf_REF ||
 284                     PL_op->op_private & HINT_STRICT_REFS)
 285                     DIE(aTHX_ PL_no_usym, "a SCALAR");
 286                 if (ckWARN(WARN_UNINITIALIZED))
 287                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
 288                 RETSETUNDEF;
 289             }
 290             sym = SvPV(sv, n_a);
 291             if ((PL_op->op_flags & OPf_SPECIAL) &&
 292                 !(PL_op->op_flags & OPf_MOD))
 293             {
 294                 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
 295                 if (!gv)
 296                     RETSETUNDEF;
 297             }
 298             else {
 299                 if (PL_op->op_private & HINT_STRICT_REFS)
 300                     DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
 301                 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
 302             }
 303         }
 304         sv = GvSV(gv);
 305     }
 306     if (PL_op->op_flags & OPf_MOD) {
 307         if (PL_op->op_private & OPpLVAL_INTRO)
 308             sv = save_scalar((GV*)TOPs);
 309         else if (PL_op->op_private & OPpDEREF)
 310             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 311     }
 312     SETs(sv);
 313     RETURN;
 314 }
 315
 316 PP(pp_av2arylen)
 317 {
 318     djSP;
 319     AV *av = (AV*)TOPs;
 320     SV *sv = AvARYLEN(av);
 321     if (!sv) {
 322         AvARYLEN(av) = sv = NEWSV(0,0);
 323         sv_upgrade(sv, SVt_IV);
 324         sv_magic(sv, (SV*)av, '#', Nullch, 0);
 325     }
 326     SETs(sv);
 327     RETURN;
 328 }
 329
 330 PP(pp_pos)
 331 {
 332     djSP; dTARGET; dPOPss;
 333
 334     if (PL_op->op_flags & OPf_MOD) {
 335         if (SvTYPE(TARG) < SVt_PVLV) {
 336             sv_upgrade(TARG, SVt_PVLV);
 337             sv_magic(TARG, Nullsv, '.', Nullch, 0);
 338         }
 339
 340         LvTYPE(TARG) = '.';
 341         if (LvTARG(TARG) != sv) {
 342             if (LvTARG(TARG))
 343                 SvREFCNT_dec(LvTARG(TARG));
 344             LvTARG(TARG) = SvREFCNT_inc(sv);
 345         }
 346         PUSHs(TARG);    /* no SvSETMAGIC */
 347         RETURN;
 348     }
 349     else {
 350         MAGIC* mg;
 351
 352         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 353             mg = mg_find(sv, 'g');
 354             if (mg && mg->mg_len >= 0) {
 355                 I32 i = mg->mg_len;
 356                 if (IN_UTF8)
 357                     sv_pos_b2u(sv, &i);
 358                 PUSHi(i + PL_curcop->cop_arybase);
 359                 RETURN;
 360             }
 361         }
 362         RETPUSHUNDEF;
 363     }
 364 }
 365
 366 PP(pp_rv2cv)
 367 {
 368     djSP;
 369     GV *gv;
 370     HV *stash;
 371
 372     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 373     /* (But not in defined().) */
 374     CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
 375     if (cv) {
 376         if (CvCLONE(cv))
 377             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 378         if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
 379             Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
 380     }
 381     else
 382         cv = (CV*)&PL_sv_undef;
 383     SETs((SV*)cv);
 384     RETURN;
 385 }
 386
 387 PP(pp_prototype)
 388 {
 389     djSP;
 390     CV *cv;
 391     HV *stash;
 392     GV *gv;
 393     SV *ret;
 394
 395     ret = &PL_sv_undef;
 396     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 397         char *s = SvPVX(TOPs);
 398         if (strnEQ(s, "CORE::", 6)) {
 399             int code;
 400
 401             code = keyword(s + 6, SvCUR(TOPs) - 6);
 402             if (code < 0) {     /* Overridable. */
 403 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 404                 int i = 0, n = 0, seen_question = 0;
 405                 I32 oa;
 406                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 407
 408                 while (i < MAXO) {      /* The slow way. */
 409                     if (strEQ(s + 6, PL_op_name[i])
 410                         || strEQ(s + 6, PL_op_desc[i]))
 411                     {
 412                         goto found;
 413                     }
 414                     i++;
 415                 }
 416                 goto nonesuch;          /* Should not happen... */
 417               found:
 418                 oa = PL_opargs[i] >> OASHIFT;
 419                 while (oa) {
 420                     if (oa & OA_OPTIONAL) {
 421                         seen_question = 1;
 422                         str[n++] = ';';
 423                     }
 424                     else if (seen_question)
 425                         goto set;       /* XXXX system, exec */
 426                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 427                         && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
 428                         str[n++] = '\\';
 429                     }
 430                     /* What to do with R ((un)tie, tied, (sys)read, recv)? */
 431                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 432                     oa = oa >> 4;
 433                 }
 434                 str[n++] = '\0';
 435                 ret = sv_2mortal(newSVpvn(str, n - 1));
 436             }
 437             else if (code)              /* Non-Overridable */
 438                 goto set;
 439             else {                      /* None such */
 440               nonesuch:
 441                 Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
 442             }
 443         }
 444     }
 445     cv = sv_2cv(TOPs, &stash, &gv, FALSE);
 446     if (cv && SvPOK(cv))
 447         ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
 448   set:
 449     SETs(ret);
 450     RETURN;
 451 }
 452
 453 PP(pp_anoncode)
 454 {
 455     djSP;
 456     CV* cv = (CV*)PL_curpad[PL_op->op_targ];
 457     if (CvCLONE(cv))
 458         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 459     EXTEND(SP,1);
 460     PUSHs((SV*)cv);
 461     RETURN;
 462 }
 463
 464 PP(pp_srefgen)
 465 {
 466     djSP;
 467     *SP = refto(*SP);
 468     RETURN;
 469 }
 470
 471 PP(pp_refgen)
 472 {
 473     djSP; dMARK;
 474     if (GIMME != G_ARRAY) {
 475         if (++MARK <= SP)
 476             *MARK = *SP;
 477         else
 478             *MARK = &PL_sv_undef;
 479         *MARK = refto(*MARK);
 480         SP = MARK;
 481         RETURN;
 482     }
 483     EXTEND_MORTAL(SP - MARK);
 484     while (++MARK <= SP)
 485         *MARK = refto(*MARK);
 486     RETURN;
 487 }
 488
 489 STATIC SV*
 490 S_refto(pTHX_ SV *sv)
 491 {
 492     SV* rv;
 493
 494     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 495         if (LvTARGLEN(sv))
 496             vivify_defelem(sv);
 497         if (!(sv = LvTARG(sv)))
 498             sv = &PL_sv_undef;
 499         else
 500             (void)SvREFCNT_inc(sv);
 501     }
 502     else if (SvPADTMP(sv))
 503         sv = newSVsv(sv);
 504     else {
 505         SvTEMP_off(sv);
 506         (void)SvREFCNT_inc(sv);
 507     }
 508     rv = sv_newmortal();
 509     sv_upgrade(rv, SVt_RV);
 510     SvRV(rv) = sv;
 511     SvROK_on(rv);
 512     return rv;
 513 }
 514
 515 PP(pp_ref)
 516 {
 517     djSP; dTARGET;
 518     SV *sv;
 519     char *pv;
 520
 521     sv = POPs;
 522
 523     if (sv && SvGMAGICAL(sv))
 524         mg_get(sv);
 525
 526     if (!sv || !SvROK(sv))
 527         RETPUSHNO;
 528
 529     sv = SvRV(sv);
 530     pv = sv_reftype(sv,TRUE);
 531     PUSHp(pv, strlen(pv));
 532     RETURN;
 533 }
 534
 535 PP(pp_bless)
 536 {
 537     djSP;
 538     HV *stash;
 539
 540     if (MAXARG == 1)
 541         stash = PL_curcop->cop_stash;
 542     else {
 543         SV *ssv = POPs;
 544         STRLEN len;
 545         char *ptr = SvPV(ssv,len);
 546         if (ckWARN(WARN_UNSAFE) && len == 0)
 547             Perl_warner(aTHX_ WARN_UNSAFE,
 548                    "Explicit blessing to '' (assuming package main)");
 549         stash = gv_stashpvn(ptr, len, TRUE);
 550     }
 551
 552     (void)sv_bless(TOPs, stash);
 553     RETURN;
 554 }
 555
 556 PP(pp_gelem)
 557 {
 558     GV *gv;
 559     SV *sv;
 560     SV *tmpRef;
 561     char *elem;
 562     djSP;
 563     STRLEN n_a;
 564
 565     sv = POPs;
 566     elem = SvPV(sv, n_a);
 567     gv = (GV*)POPs;
 568     tmpRef = Nullsv;
 569     sv = Nullsv;
 570     switch (elem ? *elem : '\0')
 571     {
 572     case 'A':
 573         if (strEQ(elem, "ARRAY"))
 574             tmpRef = (SV*)GvAV(gv);
 575         break;
 576     case 'C':
 577         if (strEQ(elem, "CODE"))
 578             tmpRef = (SV*)GvCVu(gv);
 579         break;
 580     case 'F':
 581         if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
 582             tmpRef = (SV*)GvIOp(gv);
 583         break;
 584     case 'G':
 585         if (strEQ(elem, "GLOB"))
 586             tmpRef = (SV*)gv;
 587         break;
 588     case 'H':
 589         if (strEQ(elem, "HASH"))
 590             tmpRef = (SV*)GvHV(gv);
 591         break;
 592     case 'I':
 593         if (strEQ(elem, "IO"))
 594             tmpRef = (SV*)GvIOp(gv);
 595         break;
 596     case 'N':
 597         if (strEQ(elem, "NAME"))
 598             sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
 599         break;
 600     case 'P':
 601         if (strEQ(elem, "PACKAGE"))
 602             sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
 603         break;
 604     case 'S':
 605         if (strEQ(elem, "SCALAR"))
 606             tmpRef = GvSV(gv);
 607         break;
 608     }
 609     if (tmpRef)
 610         sv = newRV(tmpRef);
 611     if (sv)
 612         sv_2mortal(sv);
 613     else
 614         sv = &PL_sv_undef;
 615     XPUSHs(sv);
 616     RETURN;
 617 }
 618
 619 /* Pattern matching */
 620
 621 PP(pp_study)
 622 {
 623     djSP; dPOPss;
 624     register unsigned char *s;
 625     register I32 pos;
 626     register I32 ch;
 627     register I32 *sfirst;
 628     register I32 *snext;
 629     STRLEN len;
 630
 631     if (sv == PL_lastscream) {
 632         if (SvSCREAM(sv))
 633             RETPUSHYES;
 634     }
 635     else {
 636         if (PL_lastscream) {
 637             SvSCREAM_off(PL_lastscream);
 638             SvREFCNT_dec(PL_lastscream);
 639         }
 640         PL_lastscream = SvREFCNT_inc(sv);
 641     }
 642
 643     s = (unsigned char*)(SvPV(sv, len));
 644     pos = len;
 645     if (pos <= 0)
 646         RETPUSHNO;
 647     if (pos > PL_maxscream) {
 648         if (PL_maxscream < 0) {
 649             PL_maxscream = pos + 80;
 650             New(301, PL_screamfirst, 256, I32);
 651             New(302, PL_screamnext, PL_maxscream, I32);
 652         }
 653         else {
 654             PL_maxscream = pos + pos / 4;
 655             Renew(PL_screamnext, PL_maxscream, I32);
 656         }
 657     }
 658
 659     sfirst = PL_screamfirst;
 660     snext = PL_screamnext;
 661
 662     if (!sfirst || !snext)
 663         DIE(aTHX_ "do_study: out of memory");
 664
 665     for (ch = 256; ch; --ch)
 666         *sfirst++ = -1;
 667     sfirst -= 256;
 668
 669     while (--pos >= 0) {
 670         ch = s[pos];
 671         if (sfirst[ch] >= 0)
 672             snext[pos] = sfirst[ch] - pos;
 673         else
 674             snext[pos] = -pos;
 675         sfirst[ch] = pos;
 676     }
 677
 678     SvSCREAM_on(sv);
 679     sv_magic(sv, Nullsv, 'g', Nullch, 0);       /* piggyback on m//g magic */
 680     RETPUSHYES;
 681 }
 682
 683 PP(pp_trans)
 684 {
 685     djSP; dTARG;
 686     SV *sv;
 687
 688     if (PL_op->op_flags & OPf_STACKED)
 689         sv = POPs;
 690     else {
 691         sv = DEFSV;
 692         EXTEND(SP,1);
 693     }
 694     TARG = sv_newmortal();
 695     PUSHi(do_trans(sv));
 696     RETURN;
 697 }
 698
 699 /* Lvalue operators. */
 700
 701 PP(pp_schop)
 702 {
 703     djSP; dTARGET;
 704     do_chop(TARG, TOPs);
 705     SETTARG;
 706     RETURN;
 707 }
 708
 709 PP(pp_chop)
 710 {
 711     djSP; dMARK; dTARGET;
 712     while (SP > MARK)
 713         do_chop(TARG, POPs);
 714     PUSHTARG;
 715     RETURN;
 716 }
 717
 718 PP(pp_schomp)
 719 {
 720     djSP; dTARGET;
 721     SETi(do_chomp(TOPs));
 722     RETURN;
 723 }
 724
 725 PP(pp_chomp)
 726 {
 727     djSP; dMARK; dTARGET;
 728     register I32 count = 0;
 729
 730     while (SP > MARK)
 731         count += do_chomp(POPs);
 732     PUSHi(count);
 733     RETURN;
 734 }
 735
 736 PP(pp_defined)
 737 {
 738     djSP;
 739     register SV* sv;
 740
 741     sv = POPs;
 742     if (!sv || !SvANY(sv))
 743         RETPUSHNO;
 744     switch (SvTYPE(sv)) {
 745     case SVt_PVAV:
 746         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
 747             RETPUSHYES;
 748         break;
 749     case SVt_PVHV:
 750         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
 751             RETPUSHYES;
 752         break;
 753     case SVt_PVCV:
 754         if (CvROOT(sv) || CvXSUB(sv))
 755             RETPUSHYES;
 756         break;
 757     default:
 758         if (SvGMAGICAL(sv))
 759             mg_get(sv);
 760         if (SvOK(sv))
 761             RETPUSHYES;
 762     }
 763     RETPUSHNO;
 764 }
 765
 766 PP(pp_undef)
 767 {
 768     djSP;
 769     SV *sv;
 770
 771     if (!PL_op->op_private) {
 772         EXTEND(SP, 1);
 773         RETPUSHUNDEF;
 774     }
 775
 776     sv = POPs;
 777     if (!sv)
 778         RETPUSHUNDEF;
 779
 780     if (SvTHINKFIRST(sv))
 781         sv_force_normal(sv);
 782
 783     switch (SvTYPE(sv)) {
 784     case SVt_NULL:
 785         break;
 786     case SVt_PVAV:
 787         av_undef((AV*)sv);
 788         break;
 789     case SVt_PVHV:
 790         hv_undef((HV*)sv);
 791         break;
 792     case SVt_PVCV:
 793         if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
 794             Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
 795                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
 796         /* FALL THROUGH */
 797     case SVt_PVFM:
 798         {
 799             /* let user-undef'd sub keep its identity */
 800             GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
 801             cv_undef((CV*)sv);
 802             CvGV((CV*)sv) = gv;
 803         }
 804         break;
 805     case SVt_PVGV:
 806         if (SvFAKE(sv))
 807             SvSetMagicSV(sv, &PL_sv_undef);
 808         else {
 809             GP *gp;
 810             gp_free((GV*)sv);
 811             Newz(602, gp, 1, GP);
 812             GvGP(sv) = gp_ref(gp);
 813             GvSV(sv) = NEWSV(72,0);
 814             GvLINE(sv) = PL_curcop->cop_line;
 815             GvEGV(sv) = (GV*)sv;
 816             GvMULTI_on(sv);
 817         }
 818         break;
 819     default:
 820         if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
 821             (void)SvOOK_off(sv);
 822             Safefree(SvPVX(sv));
 823             SvPV_set(sv, Nullch);
 824             SvLEN_set(sv, 0);
 825         }
 826         (void)SvOK_off(sv);
 827         SvSETMAGIC(sv);
 828     }
 829
 830     RETPUSHUNDEF;
 831 }
 832
 833 PP(pp_predec)
 834 {
 835     djSP;
 836     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 837         Perl_croak(aTHX_ PL_no_modify);
 838     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 839         SvIVX(TOPs) != IV_MIN)
 840     {
 841         --SvIVX(TOPs);
 842         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 843     }
 844     else
 845         sv_dec(TOPs);
 846     SvSETMAGIC(TOPs);
 847     return NORMAL;
 848 }
 849
 850 PP(pp_postinc)
 851 {
 852     djSP; dTARGET;
 853     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 854         Perl_croak(aTHX_ PL_no_modify);
 855     sv_setsv(TARG, TOPs);
 856     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 857         SvIVX(TOPs) != IV_MAX)
 858     {
 859         ++SvIVX(TOPs);
 860         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 861     }
 862     else
 863         sv_inc(TOPs);
 864     SvSETMAGIC(TOPs);
 865     if (!SvOK(TARG))
 866         sv_setiv(TARG, 0);
 867     SETs(TARG);
 868     return NORMAL;
 869 }
 870
 871 PP(pp_postdec)
 872 {
 873     djSP; dTARGET;
 874     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 875         Perl_croak(aTHX_ PL_no_modify);
 876     sv_setsv(TARG, TOPs);
 877     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 878         SvIVX(TOPs) != IV_MIN)
 879     {
 880         --SvIVX(TOPs);
 881         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 882     }
 883     else
 884         sv_dec(TOPs);
 885     SvSETMAGIC(TOPs);
 886     SETs(TARG);
 887     return NORMAL;
 888 }
 889
 890 /* Ordinary operators. */
 891
 892 PP(pp_pow)
 893 {
 894     djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
 895     {
 896       dPOPTOPnnrl;
 897       SETn( pow( left, right) );
 898       RETURN;
 899     }
 900 }
 901
 902 PP(pp_multiply)
 903 {
 904     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
 905     {
 906       dPOPTOPnnrl;
 907       SETn( left * right );
 908       RETURN;
 909     }
 910 }
 911
 912 PP(pp_divide)
 913 {
 914     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
 915     {
 916       dPOPPOPnnrl;
 917       NV value;
 918       if (right == 0.0)
 919         DIE(aTHX_ "Illegal division by zero");
 920 #ifdef SLOPPYDIVIDE
 921       /* insure that 20./5. == 4. */
 922       {
 923         IV k;
 924         if ((NV)I_V(left)  == left &&
 925             (NV)I_V(right) == right &&
 926             (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
 927             value = k;
 928         }
 929         else {
 930             value = left / right;
 931         }
 932       }
 933 #else
 934       value = left / right;
 935 #endif
 936       PUSHn( value );
 937       RETURN;
 938     }
 939 }
 940
 941 PP(pp_modulo)
 942 {
 943     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
 944     {
 945         UV left;
 946         UV right;
 947         bool left_neg;
 948         bool right_neg;
 949         bool use_double = 0;
 950         NV dright;
 951         NV dleft;
 952
 953         if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
 954             IV i = SvIVX(POPs);
 955             right = (right_neg = (i < 0)) ? -i : i;
 956         }
 957         else {
 958             dright = POPn;
 959             use_double = 1;
 960             right_neg = dright < 0;
 961             if (right_neg)
 962                 dright = -dright;
 963         }
 964
 965         if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
 966             IV i = SvIVX(POPs);
 967             left = (left_neg = (i < 0)) ? -i : i;
 968         }
 969         else {
 970             dleft = POPn;
 971             if (!use_double) {
 972                 use_double = 1;
 973                 dright = right;
 974             }
 975             left_neg = dleft < 0;
 976             if (left_neg)
 977                 dleft = -dleft;
 978         }
 979
 980         if (use_double) {
 981             NV dans;
 982
 983 #if 1
 984 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
 985 #  if CASTFLAGS & 2
 986 #    define CAST_D2UV(d) U_V(d)
 987 #  else
 988 #    define CAST_D2UV(d) ((UV)(d))
 989 #  endif
 990             /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
 991              * or, in other words, precision of UV more than of NV.
 992              * But in fact the approach below turned out to be an
 993              * optimization - floor() may be slow */
 994             if (dright <= UV_MAX && dleft <= UV_MAX) {
 995                 right = CAST_D2UV(dright);
 996                 left  = CAST_D2UV(dleft);
 997                 goto do_uv;
 998             }
 999 #endif
1000
1001             /* Backward-compatibility clause: */
1002             dright = floor(dright + 0.5);
1003             dleft  = floor(dleft + 0.5);
1004
1005             if (!dright)
1006                 DIE(aTHX_ "Illegal modulus zero");
1007
1008             dans = Perl_fmod(dleft, dright);
1009             if ((left_neg != right_neg) && dans)
1010                 dans = dright - dans;
1011             if (right_neg)
1012                 dans = -dans;
1013             sv_setnv(TARG, dans);
1014         }
1015         else {
1016             UV ans;
1017
1018         do_uv:
1019             if (!right)
1020                 DIE(aTHX_ "Illegal modulus zero");
1021
1022             ans = left % right;
1023             if ((left_neg != right_neg) && ans)
1024                 ans = right - ans;
1025             if (right_neg) {
1026                 /* XXX may warn: unary minus operator applied to unsigned type */
1027                 /* could change -foo to be (~foo)+1 instead     */
1028                 if (ans <= ~((UV)IV_MAX)+1)
1029                     sv_setiv(TARG, ~ans+1);
1030                 else
1031                     sv_setnv(TARG, -(NV)ans);
1032             }
1033             else
1034                 sv_setuv(TARG, ans);
1035         }
1036         PUSHTARG;
1037         RETURN;
1038     }
1039 }
1040
1041 PP(pp_repeat)
1042 {
1043   djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1044   {
1045     register I32 count = POPi;
1046     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1047         dMARK;
1048         I32 items = SP - MARK;
1049         I32 max;
1050
1051         max = items * count;
1052         MEXTEND(MARK, max);
1053         if (count > 1) {
1054             while (SP > MARK) {
1055                 if (*SP)
1056                     SvTEMP_off((*SP));
1057                 SP--;
1058             }
1059             MARK++;
1060             repeatcpy((char*)(MARK + items), (char*)MARK,
1061                 items * sizeof(SV*), count - 1);
1062             SP += max;
1063         }
1064         else if (count <= 0)
1065             SP -= items;
1066     }
1067     else {      /* Note: mark already snarfed by pp_list */
1068         SV *tmpstr;
1069         STRLEN len;
1070
1071         tmpstr = POPs;
1072         SvSetSV(TARG, tmpstr);
1073         SvPV_force(TARG, len);
1074         if (count != 1) {
1075             if (count < 1)
1076                 SvCUR_set(TARG, 0);
1077             else {
1078                 SvGROW(TARG, (count * len) + 1);
1079                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1080                 SvCUR(TARG) *= count;
1081             }
1082             *SvEND(TARG) = '\0';
1083         }
1084         (void)SvPOK_only(TARG);
1085         PUSHTARG;
1086     }
1087     RETURN;
1088   }
1089 }
1090
1091 PP(pp_subtract)
1092 {
1093     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1094     {
1095       dPOPTOPnnrl_ul;
1096       SETn( left - right );
1097       RETURN;
1098     }
1099 }
1100
1101 PP(pp_left_shift)
1102 {
1103     djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1104     {
1105       IV shift = POPi;
1106       if (PL_op->op_private & HINT_INTEGER)
1107         SETi(TOPi << shift);
1108       else
1109         SETu(TOPu << shift);
1110       RETURN;
1111     }
1112 }
1113
1114 PP(pp_right_shift)
1115 {
1116     djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1117     {
1118       IV shift = POPi;
1119       if (PL_op->op_private & HINT_INTEGER)
1120         SETi(TOPi >> shift);
1121       else
1122         SETu(TOPu >> shift);
1123       RETURN;
1124     }
1125 }
1126
1127 PP(pp_lt)
1128 {
1129     djSP; tryAMAGICbinSET(lt,0);
1130     {
1131       dPOPnv;
1132       SETs(boolSV(TOPn < value));
1133       RETURN;
1134     }
1135 }
1136
1137 PP(pp_gt)
1138 {
1139     djSP; tryAMAGICbinSET(gt,0);
1140     {
1141       dPOPnv;
1142       SETs(boolSV(TOPn > value));
1143       RETURN;
1144     }
1145 }
1146
1147 PP(pp_le)
1148 {
1149     djSP; tryAMAGICbinSET(le,0);
1150     {
1151       dPOPnv;
1152       SETs(boolSV(TOPn <= value));
1153       RETURN;
1154     }
1155 }
1156
1157 PP(pp_ge)
1158 {
1159     djSP; tryAMAGICbinSET(ge,0);
1160     {
1161       dPOPnv;
1162       SETs(boolSV(TOPn >= value));
1163       RETURN;
1164     }
1165 }
1166
1167 PP(pp_ne)
1168 {
1169     djSP; tryAMAGICbinSET(ne,0);
1170     {
1171       dPOPnv;
1172       SETs(boolSV(TOPn != value));
1173       RETURN;
1174     }
1175 }
1176
1177 PP(pp_ncmp)
1178 {
1179     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1180     {
1181       dPOPTOPnnrl;
1182       I32 value;
1183
1184       if (left == right)
1185         value = 0;
1186       else if (left < right)
1187         value = -1;
1188       else if (left > right)
1189         value = 1;
1190       else {
1191         SETs(&PL_sv_undef);
1192         RETURN;
1193       }
1194       SETi(value);
1195       RETURN;
1196     }
1197 }
1198
1199 PP(pp_slt)
1200 {
1201     djSP; tryAMAGICbinSET(slt,0);
1202     {
1203       dPOPTOPssrl;
1204       int cmp = ((PL_op->op_private & OPpLOCALE)
1205                  ? sv_cmp_locale(left, right)
1206                  : sv_cmp(left, right));
1207       SETs(boolSV(cmp < 0));
1208       RETURN;
1209     }
1210 }
1211
1212 PP(pp_sgt)
1213 {
1214     djSP; tryAMAGICbinSET(sgt,0);
1215     {
1216       dPOPTOPssrl;
1217       int cmp = ((PL_op->op_private & OPpLOCALE)
1218                  ? sv_cmp_locale(left, right)
1219                  : sv_cmp(left, right));
1220       SETs(boolSV(cmp > 0));
1221       RETURN;
1222     }
1223 }
1224
1225 PP(pp_sle)
1226 {
1227     djSP; tryAMAGICbinSET(sle,0);
1228     {
1229       dPOPTOPssrl;
1230       int cmp = ((PL_op->op_private & OPpLOCALE)
1231                  ? sv_cmp_locale(left, right)
1232                  : sv_cmp(left, right));
1233       SETs(boolSV(cmp <= 0));
1234       RETURN;
1235     }
1236 }
1237
1238 PP(pp_sge)
1239 {
1240     djSP; tryAMAGICbinSET(sge,0);
1241     {
1242       dPOPTOPssrl;
1243       int cmp = ((PL_op->op_private & OPpLOCALE)
1244                  ? sv_cmp_locale(left, right)
1245                  : sv_cmp(left, right));
1246       SETs(boolSV(cmp >= 0));
1247       RETURN;
1248     }
1249 }
1250
1251 PP(pp_seq)
1252 {
1253     djSP; tryAMAGICbinSET(seq,0);
1254     {
1255       dPOPTOPssrl;
1256       SETs(boolSV(sv_eq(left, right)));
1257       RETURN;
1258     }
1259 }
1260
1261 PP(pp_sne)
1262 {
1263     djSP; tryAMAGICbinSET(sne,0);
1264     {
1265       dPOPTOPssrl;
1266       SETs(boolSV(!sv_eq(left, right)));
1267       RETURN;
1268     }
1269 }
1270
1271 PP(pp_scmp)
1272 {
1273     djSP; dTARGET;  tryAMAGICbin(scmp,0);
1274     {
1275       dPOPTOPssrl;
1276       int cmp = ((PL_op->op_private & OPpLOCALE)
1277                  ? sv_cmp_locale(left, right)
1278                  : sv_cmp(left, right));
1279       SETi( cmp );
1280       RETURN;
1281     }
1282 }
1283
1284 PP(pp_bit_and)
1285 {
1286     djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1287     {
1288       dPOPTOPssrl;
1289       if (SvNIOKp(left) || SvNIOKp(right)) {
1290         if (PL_op->op_private & HINT_INTEGER)
1291           SETi( SvIV(left) & SvIV(right) );
1292         else
1293           SETu( SvUV(left) & SvUV(right) );
1294       }
1295       else {
1296         do_vop(PL_op->op_type, TARG, left, right);
1297         SETTARG;
1298       }
1299       RETURN;
1300     }
1301 }
1302
1303 PP(pp_bit_xor)
1304 {
1305     djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1306     {
1307       dPOPTOPssrl;
1308       if (SvNIOKp(left) || SvNIOKp(right)) {
1309         if (PL_op->op_private & HINT_INTEGER)
1310           SETi( (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right) );
1311         else
1312           SETu( (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right) );
1313       }
1314       else {
1315         do_vop(PL_op->op_type, TARG, left, right);
1316         SETTARG;
1317       }
1318       RETURN;
1319     }
1320 }
1321
1322 PP(pp_bit_or)
1323 {
1324     djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1325     {
1326       dPOPTOPssrl;
1327       if (SvNIOKp(left) || SvNIOKp(right)) {
1328         if (PL_op->op_private & HINT_INTEGER)
1329           SETi( (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right) );
1330         else
1331           SETu( (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right) );
1332       }
1333       else {
1334         do_vop(PL_op->op_type, TARG, left, right);
1335         SETTARG;
1336       }
1337       RETURN;
1338     }
1339 }
1340
1341 PP(pp_negate)
1342 {
1343     djSP; dTARGET; tryAMAGICun(neg);
1344     {
1345         dTOPss;
1346         if (SvGMAGICAL(sv))
1347             mg_get(sv);
1348         if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1349             SETi(-SvIVX(sv));
1350         else if (SvNIOKp(sv))
1351             SETn(-SvNV(sv));
1352         else if (SvPOKp(sv)) {
1353             STRLEN len;
1354             char *s = SvPV(sv, len);
1355             if (isIDFIRST(*s)) {
1356                 sv_setpvn(TARG, "-", 1);
1357                 sv_catsv(TARG, sv);
1358             }
1359             else if (*s == '+' || *s == '-') {
1360                 sv_setsv(TARG, sv);
1361                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1362             }
1363             else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1364                 sv_setpvn(TARG, "-", 1);
1365                 sv_catsv(TARG, sv);
1366             }
1367             else
1368                 sv_setnv(TARG, -SvNV(sv));
1369             SETTARG;
1370         }
1371         else
1372             SETn(-SvNV(sv));
1373     }
1374     RETURN;
1375 }
1376
1377 PP(pp_not)
1378 {
1379     djSP; tryAMAGICunSET(not);
1380     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1381     return NORMAL;
1382 }
1383
1384 PP(pp_complement)
1385 {
1386     djSP; dTARGET; tryAMAGICun(compl);
1387     {
1388       dTOPss;
1389       if (SvNIOKp(sv)) {
1390         if (PL_op->op_private & HINT_INTEGER)
1391           SETi( ~SvIV(sv) );
1392         else
1393           SETu( ~SvUV(sv) );
1394       }
1395       else {
1396         register char *tmps;
1397         register long *tmpl;
1398         register I32 anum;
1399         STRLEN len;
1400
1401         SvSetSV(TARG, sv);
1402         tmps = SvPV_force(TARG, len);
1403         anum = len;
1404 #ifdef LIBERAL
1405         for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1406             *tmps = ~*tmps;
1407         tmpl = (long*)tmps;
1408         for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1409             *tmpl = ~*tmpl;
1410         tmps = (char*)tmpl;
1411 #endif
1412         for ( ; anum > 0; anum--, tmps++)
1413             *tmps = ~*tmps;
1414
1415         SETs(TARG);
1416       }
1417       RETURN;
1418     }
1419 }
1420
1421 /* integer versions of some of the above */
1422
1423 PP(pp_i_multiply)
1424 {
1425     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1426     {
1427       dPOPTOPiirl;
1428       SETi( left * right );
1429       RETURN;
1430     }
1431 }
1432
1433 PP(pp_i_divide)
1434 {
1435     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1436     {
1437       dPOPiv;
1438       if (value == 0)
1439         DIE(aTHX_ "Illegal division by zero");
1440       value = POPi / value;
1441       PUSHi( value );
1442       RETURN;
1443     }
1444 }
1445
1446 PP(pp_i_modulo)
1447 {
1448     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1449     {
1450       dPOPTOPiirl;
1451       if (!right)
1452         DIE(aTHX_ "Illegal modulus zero");
1453       SETi( left % right );
1454       RETURN;
1455     }
1456 }
1457
1458 PP(pp_i_add)
1459 {
1460     djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1461     {
1462       dPOPTOPiirl;
1463       SETi( left + right );
1464       RETURN;
1465     }
1466 }
1467
1468 PP(pp_i_subtract)
1469 {
1470     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1471     {
1472       dPOPTOPiirl;
1473       SETi( left - right );
1474       RETURN;
1475     }
1476 }
1477
1478 PP(pp_i_lt)
1479 {
1480     djSP; tryAMAGICbinSET(lt,0);
1481     {
1482       dPOPTOPiirl;
1483       SETs(boolSV(left < right));
1484       RETURN;
1485     }
1486 }
1487
1488 PP(pp_i_gt)
1489 {
1490     djSP; tryAMAGICbinSET(gt,0);
1491     {
1492       dPOPTOPiirl;
1493       SETs(boolSV(left > right));
1494       RETURN;
1495     }
1496 }
1497
1498 PP(pp_i_le)
1499 {
1500     djSP; tryAMAGICbinSET(le,0);
1501     {
1502       dPOPTOPiirl;
1503       SETs(boolSV(left <= right));
1504       RETURN;
1505     }
1506 }
1507
1508 PP(pp_i_ge)
1509 {
1510     djSP; tryAMAGICbinSET(ge,0);
1511     {
1512       dPOPTOPiirl;
1513       SETs(boolSV(left >= right));
1514       RETURN;
1515     }
1516 }
1517
1518 PP(pp_i_eq)
1519 {
1520     djSP; tryAMAGICbinSET(eq,0);
1521     {
1522       dPOPTOPiirl;
1523       SETs(boolSV(left == right));
1524       RETURN;
1525     }
1526 }
1527
1528 PP(pp_i_ne)
1529 {
1530     djSP; tryAMAGICbinSET(ne,0);
1531     {
1532       dPOPTOPiirl;
1533       SETs(boolSV(left != right));
1534       RETURN;
1535     }
1536 }
1537
1538 PP(pp_i_ncmp)
1539 {
1540     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1541     {
1542       dPOPTOPiirl;
1543       I32 value;
1544
1545       if (left > right)
1546         value = 1;
1547       else if (left < right)
1548         value = -1;
1549       else
1550         value = 0;
1551       SETi(value);
1552       RETURN;
1553     }
1554 }
1555
1556 PP(pp_i_negate)
1557 {
1558     djSP; dTARGET; tryAMAGICun(neg);
1559     SETi(-TOPi);
1560     RETURN;
1561 }
1562
1563 /* High falutin' math. */
1564
1565 PP(pp_atan2)
1566 {
1567     djSP; dTARGET; tryAMAGICbin(atan2,0);
1568     {
1569       dPOPTOPnnrl;
1570       SETn(Perl_atan2(left, right));
1571       RETURN;
1572     }
1573 }
1574
1575 PP(pp_sin)
1576 {
1577     djSP; dTARGET; tryAMAGICun(sin);
1578     {
1579       NV value;
1580       value = POPn;
1581       value = Perl_sin(value);
1582       XPUSHn(value);
1583       RETURN;
1584     }
1585 }
1586
1587 PP(pp_cos)
1588 {
1589     djSP; dTARGET; tryAMAGICun(cos);
1590     {
1591       NV value;
1592       value = POPn;
1593       value = Perl_cos(value);
1594       XPUSHn(value);
1595       RETURN;
1596     }
1597 }
1598
1599 /* Support Configure command-line overrides for rand() functions.
1600    After 5.005, perhaps we should replace this by Configure support
1601    for drand48(), random(), or rand().  For 5.005, though, maintain
1602    compatibility by calling rand() but allow the user to override it.
1603    See INSTALL for details.  --Andy Dougherty  15 July 1998
1604 */
1605 /* Now it's after 5.005, and Configure supports drand48() and random(),
1606    in addition to rand().  So the overrides should not be needed any more.
1607    --Jarkko Hietaniemi  27 September 1998
1608  */
1609
1610 #ifndef HAS_DRAND48_PROTO
1611 extern double drand48 (void);
1612 #endif
1613
1614 PP(pp_rand)
1615 {
1616     djSP; dTARGET;
1617     NV value;
1618     if (MAXARG < 1)
1619         value = 1.0;
1620     else
1621         value = POPn;
1622     if (value == 0.0)
1623         value = 1.0;
1624     if (!PL_srand_called) {
1625         (void)seedDrand01((Rand_seed_t)seed());
1626         PL_srand_called = TRUE;
1627     }
1628     value *= Drand01();
1629     XPUSHn(value);
1630     RETURN;
1631 }
1632
1633 PP(pp_srand)
1634 {
1635     djSP;
1636     UV anum;
1637     if (MAXARG < 1)
1638         anum = seed();
1639     else
1640         anum = POPu;
1641     (void)seedDrand01((Rand_seed_t)anum);
1642     PL_srand_called = TRUE;
1643     EXTEND(SP, 1);
1644     RETPUSHYES;
1645 }
1646
1647 STATIC U32
1648 S_seed(pTHX)
1649 {
1650     /*
1651      * This is really just a quick hack which grabs various garbage
1652      * values.  It really should be a real hash algorithm which
1653      * spreads the effect of every input bit onto every output bit,
1654      * if someone who knows about such things would bother to write it.
1655      * Might be a good idea to add that function to CORE as well.
1656      * No numbers below come from careful analysis or anything here,
1657      * except they are primes and SEED_C1 > 1E6 to get a full-width
1658      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
1659      * probably be bigger too.
1660      */
1661 #if RANDBITS > 16
1662 #  define SEED_C1       1000003
1663 #define   SEED_C4       73819
1664 #else
1665 #  define SEED_C1       25747
1666 #define   SEED_C4       20639
1667 #endif
1668 #define   SEED_C2       3
1669 #define   SEED_C3       269
1670 #define   SEED_C5       26107
1671
1672     dTHR;
1673 #ifndef PERL_NO_DEV_RANDOM
1674     int fd;
1675 #endif
1676     U32 u;
1677 #ifdef VMS
1678 #  include <starlet.h>
1679     /* when[] = (low 32 bits, high 32 bits) of time since epoch
1680      * in 100-ns units, typically incremented ever 10 ms.        */
1681     unsigned int when[2];
1682 #else
1683 #  ifdef HAS_GETTIMEOFDAY
1684     struct timeval when;
1685 #  else
1686     Time_t when;
1687 #  endif
1688 #endif
1689
1690 /* This test is an escape hatch, this symbol isn't set by Configure. */
1691 #ifndef PERL_NO_DEV_RANDOM
1692 #ifndef PERL_RANDOM_DEVICE
1693    /* /dev/random isn't used by default because reads from it will block
1694     * if there isn't enough entropy available.  You can compile with
1695     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1696     * is enough real entropy to fill the seed. */
1697 #  define PERL_RANDOM_DEVICE "/dev/urandom"
1698 #endif
1699     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1700     if (fd != -1) {
1701         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1702             u = 0;
1703         PerlLIO_close(fd);
1704         if (u)
1705             return u;
1706     }
1707 #endif
1708
1709 #ifdef VMS
1710     _ckvmssts(sys$gettim(when));
1711     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1712 #else
1713 #  ifdef HAS_GETTIMEOFDAY
1714     gettimeofday(&when,(struct timezone *) 0);
1715     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1716 #  else
1717     (void)time(&when);
1718     u = (U32)SEED_C1 * when;
1719 #  endif
1720 #endif
1721     u += SEED_C3 * (U32)getpid();
1722     u += SEED_C4 * (U32)(UV)PL_stack_sp;
1723 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
1724     u += SEED_C5 * (U32)(UV)&when;
1725 #endif
1726     return u;
1727 }
1728
1729 PP(pp_exp)
1730 {
1731     djSP; dTARGET; tryAMAGICun(exp);
1732     {
1733       NV value;
1734       value = POPn;
1735       value = Perl_exp(value);
1736       XPUSHn(value);
1737       RETURN;
1738     }
1739 }
1740
1741 PP(pp_log)
1742 {
1743     djSP; dTARGET; tryAMAGICun(log);
1744     {
1745       NV value;
1746       value = POPn;
1747       if (value <= 0.0) {
1748         RESTORE_NUMERIC_STANDARD();
1749         DIE(aTHX_ "Can't take log of %g", value);
1750       }
1751       value = Perl_log(value);
1752       XPUSHn(value);
1753       RETURN;
1754     }
1755 }
1756
1757 PP(pp_sqrt)
1758 {
1759     djSP; dTARGET; tryAMAGICun(sqrt);
1760     {
1761       NV value;
1762       value = POPn;
1763       if (value < 0.0) {
1764         RESTORE_NUMERIC_STANDARD();
1765         DIE(aTHX_ "Can't take sqrt of %g", value);
1766       }
1767       value = Perl_sqrt(value);
1768       XPUSHn(value);
1769       RETURN;
1770     }
1771 }
1772
1773 PP(pp_int)
1774 {
1775     djSP; dTARGET;
1776     {
1777       NV value = TOPn;
1778       IV iv;
1779
1780       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1781         iv = SvIVX(TOPs);
1782         SETi(iv);
1783       }
1784       else {
1785         if (value >= 0.0)
1786           (void)Perl_modf(value, &value);
1787         else {
1788           (void)Perl_modf(-value, &value);
1789           value = -value;
1790         }
1791         iv = I_V(value);
1792         if (iv == value)
1793           SETi(iv);
1794         else
1795           SETn(value);
1796       }
1797     }
1798     RETURN;
1799 }
1800
1801 PP(pp_abs)
1802 {
1803     djSP; dTARGET; tryAMAGICun(abs);
1804     {
1805       NV value = TOPn;
1806       IV iv;
1807
1808       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1809           (iv = SvIVX(TOPs)) != IV_MIN) {
1810         if (iv < 0)
1811           iv = -iv;
1812         SETi(iv);
1813       }
1814       else {
1815         if (value < 0.0)
1816             value = -value;
1817         SETn(value);
1818       }
1819     }
1820     RETURN;
1821 }
1822
1823 PP(pp_hex)
1824 {
1825     djSP; dTARGET;
1826     char *tmps;
1827     I32 argtype;
1828     STRLEN n_a;
1829
1830     tmps = POPpx;
1831     XPUSHn(scan_hex(tmps, 99, &argtype));
1832     RETURN;
1833 }
1834
1835 PP(pp_oct)
1836 {
1837     djSP; dTARGET;
1838     NV value;
1839     I32 argtype;
1840     char *tmps;
1841     STRLEN n_a;
1842
1843     tmps = POPpx;
1844     while (*tmps && isSPACE(*tmps))
1845         tmps++;
1846     if (*tmps == '0')
1847         tmps++;
1848     if (*tmps == 'x')
1849         value = scan_hex(++tmps, 99, &argtype);
1850     else if (*tmps == 'b')
1851         value = scan_bin(++tmps, 99, &argtype);
1852     else
1853         value = scan_oct(tmps, 99, &argtype);
1854     XPUSHn(value);
1855     RETURN;
1856 }
1857
1858 /* String stuff. */
1859
1860 PP(pp_length)
1861 {
1862     djSP; dTARGET;
1863
1864     if (IN_UTF8) {
1865         SETi( sv_len_utf8(TOPs) );
1866         RETURN;
1867     }
1868
1869     SETi( sv_len(TOPs) );
1870     RETURN;
1871 }
1872
1873 PP(pp_substr)
1874 {
1875     djSP; dTARGET;
1876     SV *sv;
1877     I32 len;
1878     STRLEN curlen;
1879     STRLEN utfcurlen;
1880     I32 pos;
1881     I32 rem;
1882     I32 fail;
1883     I32 lvalue = PL_op->op_flags & OPf_MOD;
1884     char *tmps;
1885     I32 arybase = PL_curcop->cop_arybase;
1886     char *repl = 0;
1887     STRLEN repl_len;
1888
1889     SvTAINTED_off(TARG);                        /* decontaminate */
1890     if (MAXARG > 2) {
1891         if (MAXARG > 3) {
1892             sv = POPs;
1893             repl = SvPV(sv, repl_len);
1894         }
1895         len = POPi;
1896     }
1897     pos = POPi;
1898     sv = POPs;
1899     PUTBACK;
1900     tmps = SvPV(sv, curlen);
1901     if (IN_UTF8) {
1902         utfcurlen = sv_len_utf8(sv);
1903         if (utfcurlen == curlen)
1904             utfcurlen = 0;
1905         else
1906             curlen = utfcurlen;
1907     }
1908     else
1909         utfcurlen = 0;
1910
1911     if (pos >= arybase) {
1912         pos -= arybase;
1913         rem = curlen-pos;
1914         fail = rem;
1915         if (MAXARG > 2) {
1916             if (len < 0) {
1917                 rem += len;
1918                 if (rem < 0)
1919                     rem = 0;
1920             }
1921             else if (rem > len)
1922                      rem = len;
1923         }
1924     }
1925     else {
1926         pos += curlen;
1927         if (MAXARG < 3)
1928             rem = curlen;
1929         else if (len >= 0) {
1930             rem = pos+len;
1931             if (rem > (I32)curlen)
1932                 rem = curlen;
1933         }
1934         else {
1935             rem = curlen+len;
1936             if (rem < pos)
1937                 rem = pos;
1938         }
1939         if (pos < 0)
1940             pos = 0;
1941         fail = rem;
1942         rem -= pos;
1943     }
1944     if (fail < 0) {
1945         if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1946             Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
1947         RETPUSHUNDEF;
1948     }
1949     else {
1950         if (utfcurlen)
1951             sv_pos_u2b(sv, &pos, &rem);
1952         tmps += pos;
1953         sv_setpvn(TARG, tmps, rem);
1954         if (lvalue) {                   /* it's an lvalue! */
1955             if (!SvGMAGICAL(sv)) {
1956                 if (SvROK(sv)) {
1957                     STRLEN n_a;
1958                     SvPV_force(sv,n_a);
1959                     if (ckWARN(WARN_SUBSTR))
1960                         Perl_warner(aTHX_ WARN_SUBSTR,
1961                                 "Attempt to use reference as lvalue in substr");
1962                 }
1963                 if (SvOK(sv))           /* is it defined ? */
1964                     (void)SvPOK_only(sv);
1965                 else
1966                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1967             }
1968
1969             if (SvTYPE(TARG) < SVt_PVLV) {
1970                 sv_upgrade(TARG, SVt_PVLV);
1971                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1972             }
1973
1974             LvTYPE(TARG) = 'x';
1975             if (LvTARG(TARG) != sv) {
1976                 if (LvTARG(TARG))
1977                     SvREFCNT_dec(LvTARG(TARG));
1978                 LvTARG(TARG) = SvREFCNT_inc(sv);
1979             }
1980             LvTARGOFF(TARG) = pos;
1981             LvTARGLEN(TARG) = rem;
1982         }
1983         else if (repl)
1984             sv_insert(sv, pos, rem, repl, repl_len);
1985     }
1986     SPAGAIN;
1987     PUSHs(TARG);                /* avoid SvSETMAGIC here */
1988     RETURN;
1989 }
1990
1991 PP(pp_vec)
1992 {
1993     djSP; dTARGET;
1994     register I32 size = POPi;
1995     register I32 offset = POPi;
1996     register SV *src = POPs;
1997     I32 lvalue = PL_op->op_flags & OPf_MOD;
1998
1999     SvTAINTED_off(TARG);                /* decontaminate */
2000     if (lvalue) {                       /* it's an lvalue! */
2001         if (SvTYPE(TARG) < SVt_PVLV) {
2002             sv_upgrade(TARG, SVt_PVLV);
2003             sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2004         }
2005         LvTYPE(TARG) = 'v';
2006         if (LvTARG(TARG) != src) {
2007             if (LvTARG(TARG))
2008                 SvREFCNT_dec(LvTARG(TARG));
2009             LvTARG(TARG) = SvREFCNT_inc(src);
2010         }
2011         LvTARGOFF(TARG) = offset;
2012         LvTARGLEN(TARG) = size;
2013     }
2014
2015     sv_setuv(TARG, do_vecget(src, offset, size));
2016     PUSHs(TARG);
2017     RETURN;
2018 }
2019
2020 PP(pp_index)
2021 {
2022     djSP; dTARGET;
2023     SV *big;
2024     SV *little;
2025     I32 offset;
2026     I32 retval;
2027     char *tmps;
2028     char *tmps2;
2029     STRLEN biglen;
2030     I32 arybase = PL_curcop->cop_arybase;
2031
2032     if (MAXARG < 3)
2033         offset = 0;
2034     else
2035         offset = POPi - arybase;
2036     little = POPs;
2037     big = POPs;
2038     tmps = SvPV(big, biglen);
2039     if (IN_UTF8 && offset > 0)
2040         sv_pos_u2b(big, &offset, 0);
2041     if (offset < 0)
2042         offset = 0;
2043     else if (offset > biglen)
2044         offset = biglen;
2045     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2046       (unsigned char*)tmps + biglen, little, 0)))
2047         retval = -1;
2048     else
2049         retval = tmps2 - tmps;
2050     if (IN_UTF8 && retval > 0)
2051         sv_pos_b2u(big, &retval);
2052     PUSHi(retval + arybase);
2053     RETURN;
2054 }
2055
2056 PP(pp_rindex)
2057 {
2058     djSP; dTARGET;
2059     SV *big;
2060     SV *little;
2061     STRLEN blen;
2062     STRLEN llen;
2063     I32 offset;
2064     I32 retval;
2065     char *tmps;
2066     char *tmps2;
2067     I32 arybase = PL_curcop->cop_arybase;
2068
2069     if (MAXARG >= 3)
2070         offset = POPi;
2071     little = POPs;
2072     big = POPs;
2073     tmps2 = SvPV(little, llen);
2074     tmps = SvPV(big, blen);
2075     if (MAXARG < 3)
2076         offset = blen;
2077     else {
2078         if (IN_UTF8 && offset > 0)
2079             sv_pos_u2b(big, &offset, 0);
2080         offset = offset - arybase + llen;
2081     }
2082     if (offset < 0)
2083         offset = 0;
2084     else if (offset > blen)
2085         offset = blen;
2086     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2087                           tmps2, tmps2 + llen)))
2088         retval = -1;
2089     else
2090         retval = tmps2 - tmps;
2091     if (IN_UTF8 && retval > 0)
2092         sv_pos_b2u(big, &retval);
2093     PUSHi(retval + arybase);
2094     RETURN;
2095 }
2096
2097 PP(pp_sprintf)
2098 {
2099     djSP; dMARK; dORIGMARK; dTARGET;
2100     do_sprintf(TARG, SP-MARK, MARK+1);
2101     TAINT_IF(SvTAINTED(TARG));
2102     SP = ORIGMARK;
2103     PUSHTARG;
2104     RETURN;
2105 }
2106
2107 PP(pp_ord)
2108 {
2109     djSP; dTARGET;
2110     UV value;
2111     STRLEN n_a;
2112     U8 *tmps = (U8*)POPpx;
2113     I32 retlen;
2114
2115     if (IN_UTF8 && (*tmps & 0x80))
2116         value = utf8_to_uv(tmps, &retlen);
2117     else
2118         value = (UV)(*tmps & 255);
2119     XPUSHu(value);
2120     RETURN;
2121 }
2122
2123 PP(pp_chr)
2124 {
2125     djSP; dTARGET;
2126     char *tmps;
2127     U32 value = POPu;
2128
2129     (void)SvUPGRADE(TARG,SVt_PV);
2130
2131     if (IN_UTF8 && value >= 128) {
2132         SvGROW(TARG,8);
2133         tmps = SvPVX(TARG);
2134         tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2135         SvCUR_set(TARG, tmps - SvPVX(TARG));
2136         *tmps = '\0';
2137         (void)SvPOK_only(TARG);
2138         XPUSHs(TARG);
2139         RETURN;
2140     }
2141
2142     SvGROW(TARG,2);
2143     SvCUR_set(TARG, 1);
2144     tmps = SvPVX(TARG);
2145     *tmps++ = value;
2146     *tmps = '\0';
2147     (void)SvPOK_only(TARG);
2148     XPUSHs(TARG);
2149     RETURN;
2150 }
2151
2152 PP(pp_crypt)
2153 {
2154     djSP; dTARGET; dPOPTOPssrl;
2155     STRLEN n_a;
2156 #ifdef HAS_CRYPT
2157     char *tmps = SvPV(left, n_a);
2158 #ifdef FCRYPT
2159     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2160 #else
2161     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2162 #endif
2163 #else
2164     DIE(aTHX_
2165       "The crypt() function is unimplemented due to excessive paranoia.");
2166 #endif
2167     SETs(TARG);
2168     RETURN;
2169 }
2170
2171 PP(pp_ucfirst)
2172 {
2173     djSP;
2174     SV *sv = TOPs;
2175     register U8 *s;
2176     STRLEN slen;
2177
2178     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2179         I32 ulen;
2180         U8 tmpbuf[10];
2181         U8 *tend;
2182         UV uv = utf8_to_uv(s, &ulen);
2183
2184         if (PL_op->op_private & OPpLOCALE) {
2185             TAINT;
2186             SvTAINTED_on(sv);
2187             uv = toTITLE_LC_uni(uv);
2188         }
2189         else
2190             uv = toTITLE_utf8(s);
2191
2192         tend = uv_to_utf8(tmpbuf, uv);
2193
2194         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2195             dTARGET;
2196             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2197             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2198             SETs(TARG);
2199         }
2200         else {
2201             s = (U8*)SvPV_force(sv, slen);
2202             Copy(tmpbuf, s, ulen, U8);
2203         }
2204     }
2205     else {
2206         if (!SvPADTMP(sv)) {
2207             dTARGET;
2208             sv_setsv(TARG, sv);
2209             sv = TARG;
2210             SETs(sv);
2211         }
2212         s = (U8*)SvPV_force(sv, slen);
2213         if (*s) {
2214             if (PL_op->op_private & OPpLOCALE) {
2215                 TAINT;
2216                 SvTAINTED_on(sv);
2217                 *s = toUPPER_LC(*s);
2218             }
2219             else
2220                 *s = toUPPER(*s);
2221         }
2222     }
2223     if (SvSMAGICAL(sv))
2224         mg_set(sv);
2225     RETURN;
2226 }
2227
2228 PP(pp_lcfirst)
2229 {
2230     djSP;
2231     SV *sv = TOPs;
2232     register U8 *s;
2233     STRLEN slen;
2234
2235     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2236         I32 ulen;
2237         U8 tmpbuf[10];
2238         U8 *tend;
2239         UV uv = utf8_to_uv(s, &ulen);
2240
2241         if (PL_op->op_private & OPpLOCALE) {
2242             TAINT;
2243             SvTAINTED_on(sv);
2244             uv = toLOWER_LC_uni(uv);
2245         }
2246         else
2247             uv = toLOWER_utf8(s);
2248
2249         tend = uv_to_utf8(tmpbuf, uv);
2250
2251         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2252             dTARGET;
2253             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2254             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2255             SETs(TARG);
2256         }
2257         else {
2258             s = (U8*)SvPV_force(sv, slen);
2259             Copy(tmpbuf, s, ulen, U8);
2260         }
2261     }
2262     else {
2263         if (!SvPADTMP(sv)) {
2264             dTARGET;
2265             sv_setsv(TARG, sv);
2266             sv = TARG;
2267             SETs(sv);
2268         }
2269         s = (U8*)SvPV_force(sv, slen);
2270         if (*s) {
2271             if (PL_op->op_private & OPpLOCALE) {
2272                 TAINT;
2273                 SvTAINTED_on(sv);
2274                 *s = toLOWER_LC(*s);
2275             }
2276             else
2277                 *s = toLOWER(*s);
2278         }
2279         SETs(sv);
2280     }
2281     if (SvSMAGICAL(sv))
2282         mg_set(sv);
2283     RETURN;
2284 }
2285
2286 PP(pp_uc)
2287 {
2288     djSP;
2289     SV *sv = TOPs;
2290     register U8 *s;
2291     STRLEN len;
2292
2293     if (IN_UTF8) {
2294         dTARGET;
2295         I32 ulen;
2296         register U8 *d;
2297         U8 *send;
2298
2299         s = (U8*)SvPV(sv,len);
2300         if (!len) {
2301             sv_setpvn(TARG, "", 0);
2302             SETs(TARG);
2303         }
2304         else {
2305             (void)SvUPGRADE(TARG, SVt_PV);
2306             SvGROW(TARG, (len * 2) + 1);
2307             (void)SvPOK_only(TARG);
2308             d = (U8*)SvPVX(TARG);
2309             send = s + len;
2310             if (PL_op->op_private & OPpLOCALE) {
2311                 TAINT;
2312                 SvTAINTED_on(TARG);
2313                 while (s < send) {
2314                     d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2315                     s += ulen;
2316                 }
2317             }
2318             else {
2319                 while (s < send) {
2320                     d = uv_to_utf8(d, toUPPER_utf8( s ));
2321                     s += UTF8SKIP(s);
2322                 }
2323             }
2324             *d = '\0';
2325             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2326             SETs(TARG);
2327         }
2328     }
2329     else {
2330         if (!SvPADTMP(sv)) {
2331             dTARGET;
2332             sv_setsv(TARG, sv);
2333             sv = TARG;
2334             SETs(sv);
2335         }
2336         s = (U8*)SvPV_force(sv, len);
2337         if (len) {
2338             register U8 *send = s + len;
2339
2340             if (PL_op->op_private & OPpLOCALE) {
2341                 TAINT;
2342                 SvTAINTED_on(sv);
2343                 for (; s < send; s++)
2344                     *s = toUPPER_LC(*s);
2345             }
2346             else {
2347                 for (; s < send; s++)
2348                     *s = toUPPER(*s);
2349             }
2350         }
2351     }
2352     if (SvSMAGICAL(sv))
2353         mg_set(sv);
2354     RETURN;
2355 }
2356
2357 PP(pp_lc)
2358 {
2359     djSP;
2360     SV *sv = TOPs;
2361     register U8 *s;
2362     STRLEN len;
2363
2364     if (IN_UTF8) {
2365         dTARGET;
2366         I32 ulen;
2367         register U8 *d;
2368         U8 *send;
2369
2370         s = (U8*)SvPV(sv,len);
2371         if (!len) {
2372             sv_setpvn(TARG, "", 0);
2373             SETs(TARG);
2374         }
2375         else {
2376             (void)SvUPGRADE(TARG, SVt_PV);
2377             SvGROW(TARG, (len * 2) + 1);
2378             (void)SvPOK_only(TARG);
2379             d = (U8*)SvPVX(TARG);
2380             send = s + len;
2381             if (PL_op->op_private & OPpLOCALE) {
2382                 TAINT;
2383                 SvTAINTED_on(TARG);
2384                 while (s < send) {
2385                     d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2386                     s += ulen;
2387                 }
2388             }
2389             else {
2390                 while (s < send) {
2391                     d = uv_to_utf8(d, toLOWER_utf8(s));
2392                     s += UTF8SKIP(s);
2393                 }
2394             }
2395             *d = '\0';
2396             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2397             SETs(TARG);
2398         }
2399     }
2400     else {
2401         if (!SvPADTMP(sv)) {
2402             dTARGET;
2403             sv_setsv(TARG, sv);
2404             sv = TARG;
2405             SETs(sv);
2406         }
2407
2408         s = (U8*)SvPV_force(sv, len);
2409         if (len) {
2410             register U8 *send = s + len;
2411
2412             if (PL_op->op_private & OPpLOCALE) {
2413                 TAINT;
2414                 SvTAINTED_on(sv);
2415                 for (; s < send; s++)
2416                     *s = toLOWER_LC(*s);
2417             }
2418             else {
2419                 for (; s < send; s++)
2420                     *s = toLOWER(*s);
2421             }
2422         }
2423     }
2424     if (SvSMAGICAL(sv))
2425         mg_set(sv);
2426     RETURN;
2427 }
2428
2429 PP(pp_quotemeta)
2430 {
2431     djSP; dTARGET;
2432     SV *sv = TOPs;
2433     STRLEN len;
2434     register char *s = SvPV(sv,len);
2435     register char *d;
2436
2437     if (len) {
2438         (void)SvUPGRADE(TARG, SVt_PV);
2439         SvGROW(TARG, (len * 2) + 1);
2440         d = SvPVX(TARG);
2441         if (IN_UTF8) {
2442             while (len) {
2443                 if (*s & 0x80) {
2444                     STRLEN ulen = UTF8SKIP(s);
2445                     if (ulen > len)
2446                         ulen = len;
2447                     len -= ulen;
2448                     while (ulen--)
2449                         *d++ = *s++;
2450                 }
2451                 else {
2452                     if (!isALNUM(*s))
2453                         *d++ = '\\';
2454                     *d++ = *s++;
2455                     len--;
2456                 }
2457             }
2458         }
2459         else {
2460             while (len--) {
2461                 if (!isALNUM(*s))
2462                     *d++ = '\\';
2463                 *d++ = *s++;
2464             }
2465         }
2466         *d = '\0';
2467         SvCUR_set(TARG, d - SvPVX(TARG));
2468         (void)SvPOK_only(TARG);
2469     }
2470     else
2471         sv_setpvn(TARG, s, len);
2472     SETs(TARG);
2473     if (SvSMAGICAL(TARG))
2474         mg_set(TARG);
2475     RETURN;
2476 }
2477
2478 /* Arrays. */
2479
2480 PP(pp_aslice)
2481 {
2482     djSP; dMARK; dORIGMARK;
2483     register SV** svp;
2484     register AV* av = (AV*)POPs;
2485     register I32 lval = PL_op->op_flags & OPf_MOD;
2486     I32 arybase = PL_curcop->cop_arybase;
2487     I32 elem;
2488
2489     if (SvTYPE(av) == SVt_PVAV) {
2490         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2491             I32 max = -1;
2492             for (svp = MARK + 1; svp <= SP; svp++) {
2493                 elem = SvIVx(*svp);
2494                 if (elem > max)
2495                     max = elem;
2496             }
2497             if (max > AvMAX(av))
2498                 av_extend(av, max);
2499         }
2500         while (++MARK <= SP) {
2501             elem = SvIVx(*MARK);
2502
2503             if (elem > 0)
2504                 elem -= arybase;
2505             svp = av_fetch(av, elem, lval);
2506             if (lval) {
2507                 if (!svp || *svp == &PL_sv_undef)
2508                     DIE(aTHX_ PL_no_aelem, elem);
2509                 if (PL_op->op_private & OPpLVAL_INTRO)
2510                     save_aelem(av, elem, svp);
2511             }
2512             *MARK = svp ? *svp : &PL_sv_undef;
2513         }
2514     }
2515     if (GIMME != G_ARRAY) {
2516         MARK = ORIGMARK;
2517         *++MARK = *SP;
2518         SP = MARK;
2519     }
2520     RETURN;
2521 }
2522
2523 /* Associative arrays. */
2524
2525 PP(pp_each)
2526 {
2527     djSP;
2528     HV *hash = (HV*)POPs;
2529     HE *entry;
2530     I32 gimme = GIMME_V;
2531     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2532
2533     PUTBACK;
2534     /* might clobber stack_sp */
2535     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2536     SPAGAIN;
2537
2538     EXTEND(SP, 2);
2539     if (entry) {
2540         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2541         if (gimme == G_ARRAY) {
2542             SV *val;
2543             PUTBACK;
2544             /* might clobber stack_sp */
2545             val = realhv ?
2546                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2547             SPAGAIN;
2548             PUSHs(val);
2549         }
2550     }
2551     else if (gimme == G_SCALAR)
2552         RETPUSHUNDEF;
2553
2554     RETURN;
2555 }
2556
2557 PP(pp_values)
2558 {
2559     return do_kv();
2560 }
2561
2562 PP(pp_keys)
2563 {
2564     return do_kv();
2565 }
2566
2567 PP(pp_delete)
2568 {
2569     djSP;
2570     I32 gimme = GIMME_V;
2571     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2572     SV *sv;
2573     HV *hv;
2574
2575     if (PL_op->op_private & OPpSLICE) {
2576         dMARK; dORIGMARK;
2577         U32 hvtype;
2578         hv = (HV*)POPs;
2579         hvtype = SvTYPE(hv);
2580         while (++MARK <= SP) {
2581             if (hvtype == SVt_PVHV)
2582                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2583             else
2584                 DIE(aTHX_ "Not a HASH reference");
2585             *MARK = sv ? sv : &PL_sv_undef;
2586         }
2587         if (discard)
2588             SP = ORIGMARK;
2589         else if (gimme == G_SCALAR) {
2590             MARK = ORIGMARK;
2591             *++MARK = *SP;
2592             SP = MARK;
2593         }
2594     }
2595     else {
2596         SV *keysv = POPs;
2597         hv = (HV*)POPs;
2598         if (SvTYPE(hv) == SVt_PVHV)
2599             sv = hv_delete_ent(hv, keysv, discard, 0);
2600         else
2601             DIE(aTHX_ "Not a HASH reference");
2602         if (!sv)
2603             sv = &PL_sv_undef;
2604         if (!discard)
2605             PUSHs(sv);
2606     }
2607     RETURN;
2608 }
2609
2610 PP(pp_exists)
2611 {
2612     djSP;
2613     SV *tmpsv = POPs;
2614     HV *hv = (HV*)POPs;
2615     if (SvTYPE(hv) == SVt_PVHV) {
2616         if (hv_exists_ent(hv, tmpsv, 0))
2617             RETPUSHYES;
2618     }
2619     else if (SvTYPE(hv) == SVt_PVAV) {
2620         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2621             RETPUSHYES;
2622     }
2623     else {
2624         DIE(aTHX_ "Not a HASH reference");
2625     }
2626     RETPUSHNO;
2627 }
2628
2629 PP(pp_hslice)
2630 {
2631     djSP; dMARK; dORIGMARK;
2632     register HV *hv = (HV*)POPs;
2633     register I32 lval = PL_op->op_flags & OPf_MOD;
2634     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2635
2636     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2637         DIE(aTHX_ "Can't localize pseudo-hash element");
2638
2639     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2640         while (++MARK <= SP) {
2641             SV *keysv = *MARK;
2642             SV **svp;
2643             if (realhv) {
2644                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2645                 svp = he ? &HeVAL(he) : 0;
2646             }
2647             else {
2648                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2649             }
2650             if (lval) {
2651                 if (!svp || *svp == &PL_sv_undef) {
2652                     STRLEN n_a;
2653                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2654                 }
2655                 if (PL_op->op_private & OPpLVAL_INTRO)
2656                     save_helem(hv, keysv, svp);
2657             }
2658             *MARK = svp ? *svp : &PL_sv_undef;
2659         }
2660     }
2661     if (GIMME != G_ARRAY) {
2662         MARK = ORIGMARK;
2663         *++MARK = *SP;
2664         SP = MARK;
2665     }
2666     RETURN;
2667 }
2668
2669 /* List operators. */
2670
2671 PP(pp_list)
2672 {
2673     djSP; dMARK;
2674     if (GIMME != G_ARRAY) {
2675         if (++MARK <= SP)
2676             *MARK = *SP;                /* unwanted list, return last item */
2677         else
2678             *MARK = &PL_sv_undef;
2679         SP = MARK;
2680     }
2681     RETURN;
2682 }
2683
2684 PP(pp_lslice)
2685 {
2686     djSP;
2687     SV **lastrelem = PL_stack_sp;
2688     SV **lastlelem = PL_stack_base + POPMARK;
2689     SV **firstlelem = PL_stack_base + POPMARK + 1;
2690     register SV **firstrelem = lastlelem + 1;
2691     I32 arybase = PL_curcop->cop_arybase;
2692     I32 lval = PL_op->op_flags & OPf_MOD;
2693     I32 is_something_there = lval;
2694
2695     register I32 max = lastrelem - lastlelem;
2696     register SV **lelem;
2697     register I32 ix;
2698
2699     if (GIMME != G_ARRAY) {
2700         ix = SvIVx(*lastlelem);
2701         if (ix < 0)
2702             ix += max;
2703         else
2704             ix -= arybase;
2705         if (ix < 0 || ix >= max)
2706             *firstlelem = &PL_sv_undef;
2707         else
2708             *firstlelem = firstrelem[ix];
2709         SP = firstlelem;
2710         RETURN;
2711     }
2712
2713     if (max == 0) {
2714         SP = firstlelem - 1;
2715         RETURN;
2716     }
2717
2718     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2719         ix = SvIVx(*lelem);
2720         if (ix < 0)
2721             ix += max;
2722         else
2723             ix -= arybase;
2724         if (ix < 0 || ix >= max)
2725             *lelem = &PL_sv_undef;
2726         else {
2727             is_something_there = TRUE;
2728             if (!(*lelem = firstrelem[ix]))
2729                 *lelem = &PL_sv_undef;
2730         }
2731     }
2732     if (is_something_there)
2733         SP = lastlelem;
2734     else
2735         SP = firstlelem - 1;
2736     RETURN;
2737 }
2738
2739 PP(pp_anonlist)
2740 {
2741     djSP; dMARK; dORIGMARK;
2742     I32 items = SP - MARK;
2743     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2744     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2745     XPUSHs(av);
2746     RETURN;
2747 }
2748
2749 PP(pp_anonhash)
2750 {
2751     djSP; dMARK; dORIGMARK;
2752     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2753
2754     while (MARK < SP) {
2755         SV* key = *++MARK;
2756         SV *val = NEWSV(46, 0);
2757         if (MARK < SP)
2758             sv_setsv(val, *++MARK);
2759         else if (ckWARN(WARN_UNSAFE))
2760             Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2761         (void)hv_store_ent(hv,key,val,0);
2762     }
2763     SP = ORIGMARK;
2764     XPUSHs((SV*)hv);
2765     RETURN;
2766 }
2767
2768 PP(pp_splice)
2769 {
2770     djSP; dMARK; dORIGMARK;
2771     register AV *ary = (AV*)*++MARK;
2772     register SV **src;
2773     register SV **dst;
2774     register I32 i;
2775     register I32 offset;
2776     register I32 length;
2777     I32 newlen;
2778     I32 after;
2779     I32 diff;
2780     SV **tmparyval = 0;
2781     MAGIC *mg;
2782
2783     if (mg = SvTIED_mg((SV*)ary, 'P')) {
2784         *MARK-- = SvTIED_obj((SV*)ary, mg);
2785         PUSHMARK(MARK);
2786         PUTBACK;
2787         ENTER;
2788         call_method("SPLICE",GIMME_V);
2789         LEAVE;
2790         SPAGAIN;
2791         RETURN;
2792     }
2793
2794     SP++;
2795
2796     if (++MARK < SP) {
2797         offset = i = SvIVx(*MARK);
2798         if (offset < 0)
2799             offset += AvFILLp(ary) + 1;
2800         else
2801             offset -= PL_curcop->cop_arybase;
2802         if (offset < 0)
2803             DIE(aTHX_ PL_no_aelem, i);
2804         if (++MARK < SP) {
2805             length = SvIVx(*MARK++);
2806             if (length < 0) {
2807                 length += AvFILLp(ary) - offset + 1;
2808                 if (length < 0)
2809                     length = 0;
2810             }
2811         }
2812         else
2813             length = AvMAX(ary) + 1;            /* close enough to infinity */
2814     }
2815     else {
2816         offset = 0;
2817         length = AvMAX(ary) + 1;
2818     }
2819     if (offset > AvFILLp(ary) + 1)
2820         offset = AvFILLp(ary) + 1;
2821     after = AvFILLp(ary) + 1 - (offset + length);
2822     if (after < 0) {                            /* not that much array */
2823         length += after;                        /* offset+length now in array */
2824         after = 0;
2825         if (!AvALLOC(ary))
2826             av_extend(ary, 0);
2827     }
2828
2829     /* At this point, MARK .. SP-1 is our new LIST */
2830
2831     newlen = SP - MARK;
2832     diff = newlen - length;
2833     if (newlen && !AvREAL(ary) && AvREIFY(ary))
2834         av_reify(ary);
2835
2836     if (diff < 0) {                             /* shrinking the area */
2837         if (newlen) {
2838             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2839             Copy(MARK, tmparyval, newlen, SV*);
2840         }
2841
2842         MARK = ORIGMARK + 1;
2843         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2844             MEXTEND(MARK, length);
2845             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2846             if (AvREAL(ary)) {
2847                 EXTEND_MORTAL(length);
2848                 for (i = length, dst = MARK; i; i--) {
2849                     sv_2mortal(*dst);   /* free them eventualy */
2850                     dst++;
2851                 }
2852             }
2853             MARK += length - 1;
2854         }
2855         else {
2856             *MARK = AvARRAY(ary)[offset+length-1];
2857             if (AvREAL(ary)) {
2858                 sv_2mortal(*MARK);
2859                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2860                     SvREFCNT_dec(*dst++);       /* free them now */
2861             }
2862         }
2863         AvFILLp(ary) += diff;
2864
2865         /* pull up or down? */
2866
2867         if (offset < after) {                   /* easier to pull up */
2868             if (offset) {                       /* esp. if nothing to pull */
2869                 src = &AvARRAY(ary)[offset-1];
2870                 dst = src - diff;               /* diff is negative */
2871                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2872                     *dst-- = *src--;
2873             }
2874             dst = AvARRAY(ary);
2875             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2876             AvMAX(ary) += diff;
2877         }
2878         else {
2879             if (after) {                        /* anything to pull down? */
2880                 src = AvARRAY(ary) + offset + length;
2881                 dst = src + diff;               /* diff is negative */
2882                 Move(src, dst, after, SV*);
2883             }
2884             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2885                                                 /* avoid later double free */
2886         }
2887         i = -diff;
2888         while (i)
2889             dst[--i] = &PL_sv_undef;
2890
2891         if (newlen) {
2892             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2893               newlen; newlen--) {
2894                 *dst = NEWSV(46, 0);
2895                 sv_setsv(*dst++, *src++);
2896             }
2897             Safefree(tmparyval);
2898         }
2899     }
2900     else {                                      /* no, expanding (or same) */
2901         if (length) {
2902             New(452, tmparyval, length, SV*);   /* so remember deletion */
2903             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2904         }
2905
2906         if (diff > 0) {                         /* expanding */
2907
2908             /* push up or down? */
2909
2910             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2911                 if (offset) {
2912                     src = AvARRAY(ary);
2913                     dst = src - diff;
2914                     Move(src, dst, offset, SV*);
2915                 }
2916                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2917                 AvMAX(ary) += diff;
2918                 AvFILLp(ary) += diff;
2919             }
2920             else {
2921                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2922                     av_extend(ary, AvFILLp(ary) + diff);
2923                 AvFILLp(ary) += diff;
2924
2925                 if (after) {
2926                     dst = AvARRAY(ary) + AvFILLp(ary);
2927                     src = dst - diff;
2928                     for (i = after; i; i--) {
2929                         *dst-- = *src--;
2930                     }
2931                 }
2932             }
2933         }
2934
2935         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2936             *dst = NEWSV(46, 0);
2937             sv_setsv(*dst++, *src++);
2938         }
2939         MARK = ORIGMARK + 1;
2940         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2941             if (length) {
2942                 Copy(tmparyval, MARK, length, SV*);
2943                 if (AvREAL(ary)) {
2944                     EXTEND_MORTAL(length);
2945                     for (i = length, dst = MARK; i; i--) {
2946                         sv_2mortal(*dst);       /* free them eventualy */
2947                         dst++;
2948                     }
2949                 }
2950                 Safefree(tmparyval);
2951             }
2952             MARK += length - 1;
2953         }
2954         else if (length--) {
2955             *MARK = tmparyval[length];
2956             if (AvREAL(ary)) {
2957                 sv_2mortal(*MARK);
2958                 while (length-- > 0)
2959                     SvREFCNT_dec(tmparyval[length]);
2960             }
2961             Safefree(tmparyval);
2962         }
2963         else
2964             *MARK = &PL_sv_undef;
2965     }
2966     SP = MARK;
2967     RETURN;
2968 }
2969
2970 PP(pp_push)
2971 {
2972     djSP; dMARK; dORIGMARK; dTARGET;
2973     register AV *ary = (AV*)*++MARK;
2974     register SV *sv = &PL_sv_undef;
2975     MAGIC *mg;
2976
2977     if (mg = SvTIED_mg((SV*)ary, 'P')) {
2978         *MARK-- = SvTIED_obj((SV*)ary, mg);
2979         PUSHMARK(MARK);
2980         PUTBACK;
2981         ENTER;
2982         call_method("PUSH",G_SCALAR|G_DISCARD);
2983         LEAVE;
2984         SPAGAIN;
2985     }
2986     else {
2987         /* Why no pre-extend of ary here ? */
2988         for (++MARK; MARK <= SP; MARK++) {
2989             sv = NEWSV(51, 0);
2990             if (*MARK)
2991                 sv_setsv(sv, *MARK);
2992             av_push(ary, sv);
2993         }
2994     }
2995     SP = ORIGMARK;
2996     PUSHi( AvFILL(ary) + 1 );
2997     RETURN;
2998 }
2999
3000 PP(pp_pop)
3001 {
3002     djSP;
3003     AV *av = (AV*)POPs;
3004     SV *sv = av_pop(av);
3005     if (AvREAL(av))
3006         (void)sv_2mortal(sv);
3007     PUSHs(sv);
3008     RETURN;
3009 }
3010
3011 PP(pp_shift)
3012 {
3013     djSP;
3014     AV *av = (AV*)POPs;
3015     SV *sv = av_shift(av);
3016     EXTEND(SP, 1);
3017     if (!sv)
3018         RETPUSHUNDEF;
3019     if (AvREAL(av))
3020         (void)sv_2mortal(sv);
3021     PUSHs(sv);
3022     RETURN;
3023 }
3024
3025 PP(pp_unshift)
3026 {
3027     djSP; dMARK; dORIGMARK; dTARGET;
3028     register AV *ary = (AV*)*++MARK;
3029     register SV *sv;
3030     register I32 i = 0;
3031     MAGIC *mg;
3032
3033     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3034         *MARK-- = SvTIED_obj((SV*)ary, mg);
3035         PUSHMARK(MARK);
3036         PUTBACK;
3037         ENTER;
3038         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3039         LEAVE;
3040         SPAGAIN;
3041     }
3042     else {
3043         av_unshift(ary, SP - MARK);
3044         while (MARK < SP) {
3045             sv = NEWSV(27, 0);
3046             sv_setsv(sv, *++MARK);
3047             (void)av_store(ary, i++, sv);
3048         }
3049     }
3050     SP = ORIGMARK;
3051     PUSHi( AvFILL(ary) + 1 );
3052     RETURN;
3053 }
3054
3055 PP(pp_reverse)
3056 {
3057     djSP; dMARK;
3058     register SV *tmp;
3059     SV **oldsp = SP;
3060
3061     if (GIMME == G_ARRAY) {
3062         MARK++;
3063         while (MARK < SP) {
3064             tmp = *MARK;
3065             *MARK++ = *SP;
3066             *SP-- = tmp;
3067         }
3068         SP = oldsp;
3069     }
3070     else {
3071         register char *up;
3072         register char *down;
3073         register I32 tmp;
3074         dTARGET;
3075         STRLEN len;
3076
3077         if (SP - MARK > 1)
3078             do_join(TARG, &PL_sv_no, MARK, SP);
3079         else
3080             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3081         up = SvPV_force(TARG, len);
3082         if (len > 1) {
3083             if (IN_UTF8) {      /* first reverse each character */
3084                 U8* s = (U8*)SvPVX(TARG);
3085                 U8* send = (U8*)(s + len);
3086                 while (s < send) {
3087                     if (*s < 0x80) {
3088                         s++;
3089                         continue;
3090                     }
3091                     else {
3092                         up = (char*)s;
3093                         s += UTF8SKIP(s);
3094                         down = (char*)(s - 1);
3095                         if (s > send || !((*down & 0xc0) == 0x80)) {
3096                             if (ckWARN_d(WARN_UTF8))
3097                                 Perl_warner(aTHX_ WARN_UTF8,
3098                                             "Malformed UTF-8 character");
3099                             break;
3100                         }
3101                         while (down > up) {
3102                             tmp = *up;
3103                             *up++ = *down;
3104                             *down-- = tmp;
3105                         }
3106                     }
3107                 }
3108                 up = SvPVX(TARG);
3109             }
3110             down = SvPVX(TARG) + len - 1;
3111             while (down > up) {
3112                 tmp = *up;
3113                 *up++ = *down;
3114                 *down-- = tmp;
3115             }
3116             (void)SvPOK_only(TARG);
3117         }
3118         SP = MARK + 1;
3119         SETTARG;
3120     }
3121     RETURN;
3122 }
3123
3124 STATIC SV *
3125 S_mul128(pTHX_ SV *sv, U8 m)
3126 {
3127   STRLEN          len;
3128   char           *s = SvPV(sv, len);
3129   char           *t;
3130   U32             i = 0;
3131
3132   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3133     SV             *tmpNew = newSVpvn("0000000000", 10);
3134
3135     sv_catsv(tmpNew, sv);
3136     SvREFCNT_dec(sv);           /* free old sv */
3137     sv = tmpNew;
3138     s = SvPV(sv, len);
3139   }
3140   t = s + len - 1;
3141   while (!*t)                   /* trailing '\0'? */
3142     t--;
3143   while (t > s) {
3144     i = ((*t - '0') << 7) + m;
3145     *(t--) = '0' + (i % 10);
3146     m = i / 10;
3147   }
3148   return (sv);
3149 }
3150
3151 /* Explosives and implosives. */
3152
3153 #if 'I' == 73 && 'J' == 74
3154 /* On an ASCII/ISO kind of system */
3155 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3156 #else
3157 /*
3158   Some other sort of character set - use memchr() so we don't match
3159   the null byte.
3160  */
3161 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3162 #endif
3163
3164 PP(pp_unpack)
3165 {
3166     djSP;
3167     dPOPPOPssrl;
3168     SV **oldsp = SP;
3169     I32 gimme = GIMME_V;
3170     SV *sv;
3171     STRLEN llen;
3172     STRLEN rlen;
3173     register char *pat = SvPV(left, llen);
3174     register char *s = SvPV(right, rlen);
3175     char *strend = s + rlen;
3176     char *strbeg = s;
3177     register char *patend = pat + llen;
3178     I32 datumtype;
3179     register I32 len;
3180     register I32 bits;
3181
3182     /* These must not be in registers: */
3183     I16 ashort;
3184     int aint;
3185     I32 along;
3186 #ifdef HAS_QUAD
3187     Quad_t aquad;
3188 #endif
3189     U16 aushort;
3190     unsigned int auint;
3191     U32 aulong;
3192 #ifdef HAS_QUAD
3193     Uquad_t auquad;
3194 #endif
3195     char *aptr;
3196     float afloat;
3197     double adouble;
3198     I32 checksum = 0;
3199     register U32 culong;
3200     NV cdouble;
3201     int commas = 0;
3202 #ifdef PERL_NATINT_PACK
3203     int natint;         /* native integer */
3204     int unatint;        /* unsigned native integer */
3205 #endif
3206
3207     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3208         /*SUPPRESS 530*/
3209         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3210         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3211             patend++;
3212             while (isDIGIT(*patend) || *patend == '*')
3213                 patend++;
3214         }
3215         else
3216             patend++;
3217     }
3218     while (pat < patend) {
3219       reparse:
3220         datumtype = *pat++ & 0xFF;
3221 #ifdef PERL_NATINT_PACK
3222         natint = 0;
3223 #endif
3224         if (isSPACE(datumtype))
3225             continue;
3226         if (*pat == '!') {
3227             char *natstr = "sSiIlL";
3228
3229             if (strchr(natstr, datumtype)) {
3230 #ifdef PERL_NATINT_PACK
3231                 natint = 1;
3232 #endif
3233                 pat++;
3234             }
3235             else
3236                 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
3237         }
3238         if (pat >= patend)
3239             len = 1;
3240         else if (*pat == '*') {
3241             len = strend - strbeg;      /* long enough */
3242             pat++;
3243         }
3244         else if (isDIGIT(*pat)) {
3245             len = *pat++ - '0';
3246             while (isDIGIT(*pat)) {
3247                 len = (len * 10) + (*pat++ - '0');
3248                 if (len < 0)
3249                     Perl_croak(aTHX_ "Repeat count in unpack overflows");
3250             }
3251         }
3252         else
3253             len = (datumtype != '@');
3254         switch(datumtype) {
3255         default:
3256             Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3257         case ',': /* grandfather in commas but with a warning */
3258             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3259                 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3260             break;
3261         case '%':
3262             if (len == 1 && pat[-1] != '1')
3263                 len = 16;
3264             checksum = len;
3265             culong = 0;
3266             cdouble = 0;
3267             if (pat < patend)
3268                 goto reparse;
3269             break;
3270         case '@':
3271             if (len > strend - strbeg)
3272                 DIE(aTHX_ "@ outside of string");
3273             s = strbeg + len;
3274             break;
3275         case 'X':
3276             if (len > s - strbeg)
3277                 DIE(aTHX_ "X outside of string");
3278             s -= len;
3279             break;
3280         case 'x':
3281             if (len > strend - s)
3282                 DIE(aTHX_ "x outside of string");
3283             s += len;
3284             break;
3285         case '#':
3286             if (oldsp >= SP)
3287                 DIE(aTHX_ "# must follow a numeric type");
3288             if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
3289                 DIE(aTHX_ "# must be followed by a, A or Z");
3290             datumtype = *pat++;
3291             if (*pat == '*')
3292                 pat++;          /* ignore '*' for compatibility with pack */
3293             if (isDIGIT(*pat))
3294                 DIE(aTHX_ "# cannot take a count" );
3295             len = POPi;
3296             /* drop through */
3297         case 'A':
3298         case 'Z':
3299         case 'a':
3300             if (len > strend - s)
3301                 len = strend - s;
3302             if (checksum)
3303                 goto uchar_checksum;
3304             sv = NEWSV(35, len);
3305             sv_setpvn(sv, s, len);
3306             s += len;
3307             if (datumtype == 'A' || datumtype == 'Z') {
3308                 aptr = s;       /* borrow register */
3309                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3310                     s = SvPVX(sv);
3311                     while (*s)
3312                         s++;
3313                 }
3314                 else {          /* 'A' strips both nulls and spaces */
3315                     s = SvPVX(sv) + len - 1;
3316                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3317                         s--;
3318                     *++s = '\0';
3319                 }
3320                 SvCUR_set(sv, s - SvPVX(sv));
3321                 s = aptr;       /* unborrow register */
3322             }
3323             XPUSHs(sv_2mortal(sv));
3324             break;
3325         case 'B':
3326         case 'b':
3327             if (pat[-1] == '*' || len > (strend - s) * 8)
3328                 len = (strend - s) * 8;
3329             if (checksum) {
3330                 if (!PL_bitcount) {
3331                     Newz(601, PL_bitcount, 256, char);
3332                     for (bits = 1; bits < 256; bits++) {
3333                         if (bits & 1)   PL_bitcount[bits]++;
3334                         if (bits & 2)   PL_bitcount[bits]++;
3335                         if (bits & 4)   PL_bitcount[bits]++;
3336                         if (bits & 8)   PL_bitcount[bits]++;
3337                         if (bits & 16)  PL_bitcount[bits]++;
3338                         if (bits & 32)  PL_bitcount[bits]++;
3339                         if (bits & 64)  PL_bitcount[bits]++;
3340                         if (bits & 128) PL_bitcount[bits]++;
3341                     }
3342                 }
3343                 while (len >= 8) {
3344                     culong += PL_bitcount[*(unsigned char*)s++];
3345                     len -= 8;
3346                 }
3347                 if (len) {
3348                     bits = *s;
3349                     if (datumtype == 'b') {
3350                         while (len-- > 0) {
3351                             if (bits & 1) culong++;
3352                             bits >>= 1;
3353                         }
3354                     }
3355                     else {
3356                         while (len-- > 0) {
3357                             if (bits & 128) culong++;
3358                             bits <<= 1;
3359                         }
3360                     }
3361                 }
3362                 break;
3363             }
3364             sv = NEWSV(35, len + 1);
3365             SvCUR_set(sv, len);
3366             SvPOK_on(sv);
3367             aptr = pat;                 /* borrow register */
3368             pat = SvPVX(sv);
3369             if (datumtype == 'b') {
3370                 aint = len;
3371                 for (len = 0; len < aint; len++) {
3372                     if (len & 7)                /*SUPPRESS 595*/
3373                         bits >>= 1;
3374                     else
3375                         bits = *s++;
3376                     *pat++ = '0' + (bits & 1);
3377                 }
3378             }
3379             else {
3380                 aint = len;
3381                 for (len = 0; len < aint; len++) {
3382                     if (len & 7)
3383                         bits <<= 1;
3384                     else
3385                         bits = *s++;
3386                     *pat++ = '0' + ((bits & 128) != 0);
3387                 }
3388             }
3389             *pat = '\0';
3390             pat = aptr;                 /* unborrow register */
3391             XPUSHs(sv_2mortal(sv));
3392             break;
3393         case 'H':
3394         case 'h':
3395             if (pat[-1] == '*' || len > (strend - s) * 2)
3396                 len = (strend - s) * 2;
3397             sv = NEWSV(35, len + 1);
3398             SvCUR_set(sv, len);
3399             SvPOK_on(sv);
3400             aptr = pat;                 /* borrow register */
3401             pat = SvPVX(sv);
3402             if (datumtype == 'h') {
3403                 aint = len;
3404                 for (len = 0; len < aint; len++) {
3405                     if (len & 1)
3406                         bits >>= 4;
3407                     else
3408                         bits = *s++;
3409                     *pat++ = PL_hexdigit[bits & 15];
3410                 }
3411             }
3412             else {
3413                 aint = len;
3414                 for (len = 0; len < aint; len++) {
3415                     if (len & 1)
3416                         bits <<= 4;
3417                     else
3418                         bits = *s++;
3419                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3420                 }
3421             }
3422             *pat = '\0';
3423             pat = aptr;                 /* unborrow register */
3424             XPUSHs(sv_2mortal(sv));
3425             break;
3426         case 'c':
3427             if (len > strend - s)
3428                 len = strend - s;
3429             if (checksum) {
3430                 while (len-- > 0) {
3431                     aint = *s++;
3432                     if (aint >= 128)    /* fake up signed chars */
3433                         aint -= 256;
3434                     culong += aint;
3435                 }
3436             }
3437             else {
3438                 EXTEND(SP, len);
3439                 EXTEND_MORTAL(len);
3440                 while (len-- > 0) {
3441                     aint = *s++;
3442                     if (aint >= 128)    /* fake up signed chars */
3443                         aint -= 256;
3444                     sv = NEWSV(36, 0);
3445                     sv_setiv(sv, (IV)aint);
3446                     PUSHs(sv_2mortal(sv));
3447                 }
3448             }
3449             break;
3450         case 'C':
3451             if (len > strend - s)
3452                 len = strend - s;
3453             if (checksum) {
3454               uchar_checksum:
3455                 while (len-- > 0) {
3456                     auint = *s++ & 255;
3457                     culong += auint;
3458                 }
3459             }
3460             else {
3461                 EXTEND(SP, len);
3462                 EXTEND_MORTAL(len);
3463                 while (len-- > 0) {
3464                     auint = *s++ & 255;
3465                     sv = NEWSV(37, 0);
3466                     sv_setiv(sv, (IV)auint);
3467                     PUSHs(sv_2mortal(sv));
3468                 }
3469             }
3470             break;
3471         case 'U':
3472             if (len > strend - s)
3473                 len = strend - s;
3474             if (checksum) {
3475                 while (len-- > 0 && s < strend) {
3476                     auint = utf8_to_uv((U8*)s, &along);
3477                     s += along;
3478                     if (checksum > 32)
3479                         cdouble += (NV)auint;
3480                     else
3481                         culong += auint;
3482                 }
3483             }
3484             else {
3485                 EXTEND(SP, len);
3486                 EXTEND_MORTAL(len);
3487                 while (len-- > 0 && s < strend) {
3488                     auint = utf8_to_uv((U8*)s, &along);
3489                     s += along;
3490                     sv = NEWSV(37, 0);
3491                     sv_setuv(sv, (UV)auint);
3492                     PUSHs(sv_2mortal(sv));
3493                 }
3494             }
3495             break;
3496         case 's':
3497 #if SHORTSIZE == SIZE16
3498             along = (strend - s) / SIZE16;
3499 #else
3500             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3501 #endif
3502             if (len > along)
3503                 len = along;
3504             if (checksum) {
3505 #if SHORTSIZE != SIZE16
3506                 if (natint) {
3507                     short ashort;
3508                     while (len-- > 0) {
3509                         COPYNN(s, &ashort, sizeof(short));
3510                         s += sizeof(short);
3511                         culong += ashort;
3512
3513                     }
3514                 }
3515                 else
3516 #endif
3517                 {
3518                     while (len-- > 0) {
3519                         COPY16(s, &ashort);
3520 #if SHORTSIZE > SIZE16
3521                         if (ashort > 32767)
3522                           ashort -= 65536;
3523 #endif
3524                         s += SIZE16;
3525                         culong += ashort;
3526                     }
3527                 }
3528             }
3529             else {
3530                 EXTEND(SP, len);
3531                 EXTEND_MORTAL(len);
3532 #if SHORTSIZE != SIZE16
3533                 if (natint) {
3534                     short ashort;
3535                     while (len-- > 0) {
3536                         COPYNN(s, &ashort, sizeof(short));
3537                         s += sizeof(short);
3538                         sv = NEWSV(38, 0);
3539                         sv_setiv(sv, (IV)ashort);
3540                         PUSHs(sv_2mortal(sv));
3541                     }
3542                 }
3543                 else
3544 #endif
3545                 {
3546                     while (len-- > 0) {
3547                         COPY16(s, &ashort);
3548 #if SHORTSIZE > SIZE16
3549                         if (ashort > 32767)
3550                           ashort -= 65536;
3551 #endif
3552                         s += SIZE16;
3553                         sv = NEWSV(38, 0);
3554                         sv_setiv(sv, (IV)ashort);
3555                         PUSHs(sv_2mortal(sv));
3556                     }
3557                 }
3558             }
3559             break;
3560         case 'v':
3561         case 'n':
3562         case 'S':
3563 #if SHORTSIZE == SIZE16
3564             along = (strend - s) / SIZE16;
3565 #else
3566             unatint = natint && datumtype == 'S';
3567             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3568 #endif
3569             if (len > along)
3570                 len = along;
3571             if (checksum) {
3572 #if SHORTSIZE != SIZE16
3573                 if (unatint) {
3574                     unsigned short aushort;
3575                     while (len-- > 0) {
3576                         COPYNN(s, &aushort, sizeof(unsigned short));
3577                         s += sizeof(unsigned short);
3578                         culong += aushort;
3579                     }
3580                 }
3581                 else
3582 #endif
3583                 {
3584                     while (len-- > 0) {
3585                         COPY16(s, &aushort);
3586                         s += SIZE16;
3587 #ifdef HAS_NTOHS
3588                         if (datumtype == 'n')
3589                             aushort = PerlSock_ntohs(aushort);
3590 #endif
3591 #ifdef HAS_VTOHS
3592                         if (datumtype == 'v')
3593                             aushort = vtohs(aushort);
3594 #endif
3595                         culong += aushort;
3596                     }
3597                 }
3598             }
3599             else {
3600                 EXTEND(SP, len);
3601                 EXTEND_MORTAL(len);
3602 #if SHORTSIZE != SIZE16
3603                 if (unatint) {
3604                     unsigned short aushort;
3605                     while (len-- > 0) {
3606                         COPYNN(s, &aushort, sizeof(unsigned short));
3607                         s += sizeof(unsigned short);
3608                         sv = NEWSV(39, 0);
3609                         sv_setiv(sv, (UV)aushort);
3610                         PUSHs(sv_2mortal(sv));
3611                     }
3612                 }
3613                 else
3614 #endif
3615                 {
3616                     while (len-- > 0) {
3617                         COPY16(s, &aushort);
3618                         s += SIZE16;
3619                         sv = NEWSV(39, 0);
3620 #ifdef HAS_NTOHS
3621                         if (datumtype == 'n')
3622                             aushort = PerlSock_ntohs(aushort);
3623 #endif
3624 #ifdef HAS_VTOHS
3625                         if (datumtype == 'v')
3626                             aushort = vtohs(aushort);
3627 #endif
3628                         sv_setiv(sv, (UV)aushort);
3629                         PUSHs(sv_2mortal(sv));
3630                     }
3631                 }
3632             }
3633             break;
3634         case 'i':
3635             along = (strend - s) / sizeof(int);
3636             if (len > along)
3637                 len = along;
3638             if (checksum) {
3639                 while (len-- > 0) {
3640                     Copy(s, &aint, 1, int);
3641                     s += sizeof(int);
3642                     if (checksum > 32)
3643                         cdouble += (NV)aint;
3644                     else
3645                         culong += aint;
3646                 }
3647             }
3648             else {
3649                 EXTEND(SP, len);
3650                 EXTEND_MORTAL(len);
3651                 while (len-- > 0) {
3652                     Copy(s, &aint, 1, int);
3653                     s += sizeof(int);
3654                     sv = NEWSV(40, 0);
3655 #ifdef __osf__
3656                     /* Without the dummy below unpack("i", pack("i",-1))
3657                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3658                      * cc with optimization turned on.
3659                      *
3660                      * The bug was detected in
3661                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3662                      * with optimization (-O4) turned on.
3663                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3664                      * does not have this problem even with -O4.
3665                      *
3666                      * This bug was reported as DECC_BUGS 1431
3667                      * and tracked internally as GEM_BUGS 7775.
3668                      *
3669                      * The bug is fixed in
3670                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
3671                      * UNIX V4.0F support:   DEC C V5.9-006 or later
3672                      * UNIX V4.0E support:   DEC C V5.8-011 or later
3673                      * and also in DTK.
3674                      *
3675                      * See also few lines later for the same bug.
3676                      */
3677                     (aint) ?
3678                         sv_setiv(sv, (IV)aint) :
3679 #endif
3680                     sv_setiv(sv, (IV)aint);
3681                     PUSHs(sv_2mortal(sv));
3682                 }
3683             }
3684             break;
3685         case 'I':
3686             along = (strend - s) / sizeof(unsigned int);
3687             if (len > along)
3688                 len = along;
3689             if (checksum) {
3690                 while (len-- > 0) {
3691                     Copy(s, &auint, 1, unsigned int);
3692                     s += sizeof(unsigned int);
3693                     if (checksum > 32)
3694                         cdouble += (NV)auint;
3695                     else
3696                         culong += auint;
3697                 }
3698             }
3699             else {
3700                 EXTEND(SP, len);
3701                 EXTEND_MORTAL(len);
3702                 while (len-- > 0) {
3703                     Copy(s, &auint, 1, unsigned int);
3704                     s += sizeof(unsigned int);
3705                     sv = NEWSV(41, 0);
3706 #ifdef __osf__
3707                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3708                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3709                      * See details few lines earlier. */
3710                     (auint) ?
3711                         sv_setuv(sv, (UV)auint) :
3712 #endif
3713                     sv_setuv(sv, (UV)auint);
3714                     PUSHs(sv_2mortal(sv));
3715                 }
3716             }
3717             break;
3718         case 'l':
3719 #if LONGSIZE == SIZE32
3720             along = (strend - s) / SIZE32;
3721 #else
3722             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3723 #endif
3724             if (len > along)
3725                 len = along;
3726             if (checksum) {
3727 #if LONGSIZE != SIZE32
3728                 if (natint) {
3729                     long along;
3730                     while (len-- > 0) {
3731                         COPYNN(s, &along, sizeof(long));
3732                         s += sizeof(long);
3733                         if (checksum > 32)
3734                             cdouble += (NV)along;
3735                         else
3736                             culong += along;
3737                     }
3738                 }
3739                 else
3740 #endif
3741                 {
3742                     while (len-- > 0) {
3743                         COPY32(s, &along);
3744 #if LONGSIZE > SIZE32
3745                         if (along > 2147483647)
3746                           along -= 4294967296;
3747 #endif
3748                         s += SIZE32;
3749                         if (checksum > 32)
3750                             cdouble += (NV)along;
3751                         else
3752                             culong += along;
3753                     }
3754                 }
3755             }
3756             else {
3757                 EXTEND(SP, len);
3758                 EXTEND_MORTAL(len);
3759 #if LONGSIZE != SIZE32
3760                 if (natint) {
3761                     long along;
3762                     while (len-- > 0) {
3763                         COPYNN(s, &along, sizeof(long));
3764                         s += sizeof(long);
3765                         sv = NEWSV(42, 0);
3766                         sv_setiv(sv, (IV)along);
3767                         PUSHs(sv_2mortal(sv));
3768                     }
3769                 }
3770                 else
3771 #endif
3772                 {
3773                     while (len-- > 0) {
3774                         COPY32(s, &along);
3775 #if LONGSIZE > SIZE32
3776                         if (along > 2147483647)
3777                           along -= 4294967296;
3778 #endif
3779                         s += SIZE32;
3780                         sv = NEWSV(42, 0);
3781                         sv_setiv(sv, (IV)along);
3782                         PUSHs(sv_2mortal(sv));
3783                     }
3784                 }
3785             }
3786             break;
3787         case 'V':
3788         case 'N':
3789         case 'L':
3790 #if LONGSIZE == SIZE32
3791             along = (strend - s) / SIZE32;
3792 #else
3793             unatint = natint && datumtype == 'L';
3794             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3795 #endif
3796             if (len > along)
3797                 len = along;
3798             if (checksum) {
3799 #if LONGSIZE != SIZE32
3800                 if (unatint) {
3801                     unsigned long aulong;
3802                     while (len-- > 0) {
3803                         COPYNN(s, &aulong, sizeof(unsigned long));
3804                         s += sizeof(unsigned long);
3805                         if (checksum > 32)
3806                             cdouble += (NV)aulong;
3807                         else
3808                             culong += aulong;
3809                     }
3810                 }
3811                 else
3812 #endif
3813                 {
3814                     while (len-- > 0) {
3815                         COPY32(s, &aulong);
3816                         s += SIZE32;
3817 #ifdef HAS_NTOHL
3818                         if (datumtype == 'N')
3819                             aulong = PerlSock_ntohl(aulong);
3820 #endif
3821 #ifdef HAS_VTOHL
3822                         if (datumtype == 'V')
3823                             aulong = vtohl(aulong);
3824 #endif
3825                         if (checksum > 32)
3826                             cdouble += (NV)aulong;
3827                         else
3828                             culong += aulong;
3829                     }
3830                 }
3831             }
3832             else {
3833                 EXTEND(SP, len);
3834                 EXTEND_MORTAL(len);
3835 #if LONGSIZE != SIZE32
3836                 if (unatint) {
3837                     unsigned long aulong;
3838                     while (len-- > 0) {
3839                         COPYNN(s, &aulong, sizeof(unsigned long));
3840                         s += sizeof(unsigned long);
3841                         sv = NEWSV(43, 0);
3842                         sv_setuv(sv, (UV)aulong);
3843                         PUSHs(sv_2mortal(sv));
3844                     }
3845                 }
3846                 else
3847 #endif
3848                 {
3849                     while (len-- > 0) {
3850                         COPY32(s, &aulong);
3851                         s += SIZE32;
3852 #ifdef HAS_NTOHL
3853                         if (datumtype == 'N')
3854                             aulong = PerlSock_ntohl(aulong);
3855 #endif
3856 #ifdef HAS_VTOHL
3857                         if (datumtype == 'V')
3858                             aulong = vtohl(aulong);
3859 #endif
3860                         sv = NEWSV(43, 0);
3861                         sv_setuv(sv, (UV)aulong);
3862                         PUSHs(sv_2mortal(sv));
3863                     }
3864                 }
3865             }
3866             break;
3867         case 'p':
3868             along = (strend - s) / sizeof(char*);
3869             if (len > along)
3870                 len = along;
3871             EXTEND(SP, len);
3872             EXTEND_MORTAL(len);
3873             while (len-- > 0) {
3874                 if (sizeof(char*) > strend - s)
3875                     break;
3876                 else {
3877                     Copy(s, &aptr, 1, char*);
3878                     s += sizeof(char*);
3879                 }
3880                 sv = NEWSV(44, 0);
3881                 if (aptr)
3882                     sv_setpv(sv, aptr);
3883                 PUSHs(sv_2mortal(sv));
3884             }
3885             break;
3886         case 'w':
3887             EXTEND(SP, len);
3888             EXTEND_MORTAL(len);
3889             {
3890                 UV auv = 0;
3891                 U32 bytes = 0;
3892
3893                 while ((len > 0) && (s < strend)) {
3894                     auv = (auv << 7) | (*s & 0x7f);
3895                     if (!(*s++ & 0x80)) {
3896                         bytes = 0;
3897                         sv = NEWSV(40, 0);
3898                         sv_setuv(sv, auv);
3899                         PUSHs(sv_2mortal(sv));
3900                         len--;
3901                         auv = 0;
3902                     }
3903                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3904                         char *t;
3905                         STRLEN n_a;
3906
3907                         sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3908                         while (s < strend) {
3909                             sv = mul128(sv, *s & 0x7f);
3910                             if (!(*s++ & 0x80)) {
3911                                 bytes = 0;
3912                                 break;
3913                             }
3914                         }
3915                         t = SvPV(sv, n_a);
3916                         while (*t == '0')
3917                             t++;
3918                         sv_chop(sv, t);
3919                         PUSHs(sv_2mortal(sv));
3920                         len--;
3921                         auv = 0;
3922                     }
3923                 }
3924                 if ((s >= strend) && bytes)
3925                     Perl_croak(aTHX_ "Unterminated compressed integer");
3926             }
3927             break;
3928         case 'P':
3929             EXTEND(SP, 1);
3930             if (sizeof(char*) > strend - s)
3931                 break;
3932             else {
3933                 Copy(s, &aptr, 1, char*);
3934                 s += sizeof(char*);
3935             }
3936             sv = NEWSV(44, 0);
3937             if (aptr)
3938                 sv_setpvn(sv, aptr, len);
3939             PUSHs(sv_2mortal(sv));
3940             break;
3941 #ifdef HAS_QUAD
3942         case 'q':
3943             along = (strend - s) / sizeof(Quad_t);
3944             if (len > along)
3945                 len = along;
3946             EXTEND(SP, len);
3947             EXTEND_MORTAL(len);
3948             while (len-- > 0) {
3949                 if (s + sizeof(Quad_t) > strend)
3950                     aquad = 0;
3951                 else {
3952                     Copy(s, &aquad, 1, Quad_t);
3953                     s += sizeof(Quad_t);
3954                 }
3955                 sv = NEWSV(42, 0);
3956                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3957                     sv_setiv(sv, (IV)aquad);
3958                 else
3959                     sv_setnv(sv, (NV)aquad);
3960                 PUSHs(sv_2mortal(sv));
3961             }
3962             break;
3963         case 'Q':
3964             along = (strend - s) / sizeof(Quad_t);
3965             if (len > along)
3966                 len = along;
3967             EXTEND(SP, len);
3968             EXTEND_MORTAL(len);
3969             while (len-- > 0) {
3970                 if (s + sizeof(Uquad_t) > strend)
3971                     auquad = 0;
3972                 else {
3973                     Copy(s, &auquad, 1, Uquad_t);
3974                     s += sizeof(Uquad_t);
3975                 }
3976                 sv = NEWSV(43, 0);
3977                 if (auquad <= UV_MAX)
3978                     sv_setuv(sv, (UV)auquad);
3979                 else
3980                     sv_setnv(sv, (NV)auquad);
3981                 PUSHs(sv_2mortal(sv));
3982             }
3983             break;
3984 #endif
3985         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3986         case 'f':
3987         case 'F':
3988             along = (strend - s) / sizeof(float);
3989             if (len > along)
3990                 len = along;
3991             if (checksum) {
3992                 while (len-- > 0) {
3993                     Copy(s, &afloat, 1, float);
3994                     s += sizeof(float);
3995                     cdouble += afloat;
3996                 }
3997             }
3998             else {
3999                 EXTEND(SP, len);
4000                 EXTEND_MORTAL(len);
4001                 while (len-- > 0) {
4002                     Copy(s, &afloat, 1, float);
4003                     s += sizeof(float);
4004                     sv = NEWSV(47, 0);
4005                     sv_setnv(sv, (NV)afloat);
4006                     PUSHs(sv_2mortal(sv));
4007                 }
4008             }
4009             break;
4010         case 'd':
4011         case 'D':
4012             along = (strend - s) / sizeof(double);
4013             if (len > along)
4014                 len = along;
4015             if (checksum) {
4016                 while (len-- > 0) {
4017                     Copy(s, &adouble, 1, double);
4018                     s += sizeof(double);
4019                     cdouble += adouble;
4020                 }
4021             }
4022             else {
4023                 EXTEND(SP, len);
4024                 EXTEND_MORTAL(len);
4025                 while (len-- > 0) {
4026                     Copy(s, &adouble, 1, double);
4027                     s += sizeof(double);
4028                     sv = NEWSV(48, 0);
4029                     sv_setnv(sv, (NV)adouble);
4030                     PUSHs(sv_2mortal(sv));
4031                 }
4032             }
4033             break;
4034         case 'u':
4035             /* MKS:
4036              * Initialise the decode mapping.  By using a table driven
4037              * algorithm, the code will be character-set independent
4038              * (and just as fast as doing character arithmetic)
4039              */
4040             if (PL_uudmap['M'] == 0) {
4041                 int i;
4042
4043                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4044                     PL_uudmap[PL_uuemap[i]] = i;
4045                 /*
4046                  * Because ' ' and '`' map to the same value,
4047                  * we need to decode them both the same.
4048                  */
4049                 PL_uudmap[' '] = 0;
4050             }
4051
4052             along = (strend - s) * 3 / 4;
4053             sv = NEWSV(42, along);
4054             if (along)
4055                 SvPOK_on(sv);
4056             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4057                 I32 a, b, c, d;
4058                 char hunk[4];
4059
4060                 hunk[3] = '\0';
4061                 len = PL_uudmap[*s++] & 077;
4062                 while (len > 0) {
4063                     if (s < strend && ISUUCHAR(*s))
4064                         a = PL_uudmap[*s++] & 077;
4065                     else
4066                         a = 0;
4067                     if (s < strend && ISUUCHAR(*s))
4068                         b = PL_uudmap[*s++] & 077;
4069                     else
4070                         b = 0;
4071                     if (s < strend && ISUUCHAR(*s))
4072                         c = PL_uudmap[*s++] & 077;
4073                     else
4074                         c = 0;
4075                     if (s < strend && ISUUCHAR(*s))
4076                         d = PL_uudmap[*s++] & 077;
4077                     else
4078                         d = 0;
4079                     hunk[0] = (a << 2) | (b >> 4);
4080                     hunk[1] = (b << 4) | (c >> 2);
4081                     hunk[2] = (c << 6) | d;
4082                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4083                     len -= 3;
4084                 }
4085                 if (*s == '\n')
4086                     s++;
4087                 else if (s[1] == '\n')          /* possible checksum byte */
4088                     s += 2;
4089             }
4090             XPUSHs(sv_2mortal(sv));
4091             break;
4092         }
4093         if (checksum) {
4094             sv = NEWSV(42, 0);
4095             if (strchr("fFdD", datumtype) ||
4096               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4097                 NV trouble;
4098
4099                 adouble = 1.0;
4100                 while (checksum >= 16) {
4101                     checksum -= 16;
4102                     adouble *= 65536.0;
4103                 }
4104                 while (checksum >= 4) {
4105                     checksum -= 4;
4106                     adouble *= 16.0;
4107                 }
4108                 while (checksum--)
4109                     adouble *= 2.0;
4110                 along = (1 << checksum) - 1;
4111                 while (cdouble < 0.0)
4112                     cdouble += adouble;
4113                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4114                 sv_setnv(sv, cdouble);
4115             }
4116             else {
4117                 if (checksum < 32) {
4118                     aulong = (1 << checksum) - 1;
4119                     culong &= aulong;
4120                 }
4121                 sv_setuv(sv, (UV)culong);
4122             }
4123             XPUSHs(sv_2mortal(sv));
4124             checksum = 0;
4125         }
4126     }
4127     if (SP == oldsp && gimme == G_SCALAR)
4128         PUSHs(&PL_sv_undef);
4129     RETURN;
4130 }
4131
4132 STATIC void
4133 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4134 {
4135     char hunk[5];
4136
4137     *hunk = PL_uuemap[len];
4138     sv_catpvn(sv, hunk, 1);
4139     hunk[4] = '\0';
4140     while (len > 2) {
4141         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4142         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4143         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4144         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4145         sv_catpvn(sv, hunk, 4);
4146         s += 3;
4147         len -= 3;
4148     }
4149     if (len > 0) {
4150         char r = (len > 1 ? s[1] : '\0');
4151         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4152         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4153         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4154         hunk[3] = PL_uuemap[0];
4155         sv_catpvn(sv, hunk, 4);
4156     }
4157     sv_catpvn(sv, "\n", 1);
4158 }
4159
4160 STATIC SV *
4161 S_is_an_int(pTHX_ char *s, STRLEN l)
4162 {
4163   STRLEN         n_a;
4164   SV             *result = newSVpvn(s, l);
4165   char           *result_c = SvPV(result, n_a); /* convenience */
4166   char           *out = result_c;
4167   bool            skip = 1;
4168   bool            ignore = 0;
4169
4170   while (*s) {
4171     switch (*s) {
4172     case ' ':
4173       break;
4174     case '+':
4175       if (!skip) {
4176         SvREFCNT_dec(result);
4177         return (NULL);
4178       }
4179       break;
4180     case '0':
4181     case '1':
4182     case '2':
4183     case '3':
4184     case '4':
4185     case '5':
4186     case '6':
4187     case '7':
4188     case '8':
4189     case '9':
4190       skip = 0;
4191       if (!ignore) {
4192         *(out++) = *s;
4193       }
4194       break;
4195     case '.':
4196       ignore = 1;
4197       break;
4198     default:
4199       SvREFCNT_dec(result);
4200       return (NULL);
4201     }
4202     s++;
4203   }
4204   *(out++) = '\0';
4205   SvCUR_set(result, out - result_c);
4206   return (result);
4207 }
4208
4209 /* pnum must be '\0' terminated */
4210 STATIC int
4211 S_div128(pTHX_ SV *pnum, bool *done)
4212 {
4213   STRLEN          len;
4214   char           *s = SvPV(pnum, len);
4215   int             m = 0;
4216   int             r = 0;
4217   char           *t = s;
4218
4219   *done = 1;
4220   while (*t) {
4221     int             i;
4222
4223     i = m * 10 + (*t - '0');
4224     m = i & 0x7F;
4225     r = (i >> 7);               /* r < 10 */
4226     if (r) {
4227       *done = 0;
4228     }
4229     *(t++) = '0' + r;
4230   }
4231   *(t++) = '\0';
4232   SvCUR_set(pnum, (STRLEN) (t - s));
4233   return (m);
4234 }
4235
4236
4237 PP(pp_pack)
4238 {
4239     djSP; dMARK; dORIGMARK; dTARGET;
4240     register SV *cat = TARG;
4241     register I32 items;
4242     STRLEN fromlen;
4243     register char *pat = SvPVx(*++MARK, fromlen);
4244     register char *patend = pat + fromlen;
4245     register I32 len;
4246     I32 datumtype;
4247     SV *fromstr;
4248     /*SUPPRESS 442*/
4249     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4250     static char *space10 = "          ";
4251
4252     /* These must not be in registers: */
4253     char achar;
4254     I16 ashort;
4255     int aint;
4256     unsigned int auint;
4257     I32 along;
4258     U32 aulong;
4259 #ifdef HAS_QUAD
4260     Quad_t aquad;
4261     Uquad_t auquad;
4262 #endif
4263     char *aptr;
4264     float afloat;
4265     double adouble;
4266     int commas = 0;
4267 #ifdef PERL_NATINT_PACK
4268     int natint;         /* native integer */
4269 #endif
4270
4271     items = SP - MARK;
4272     MARK++;
4273     sv_setpvn(cat, "", 0);
4274     while (pat < patend) {
4275         SV *lengthcode = Nullsv;
4276 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4277         datumtype = *pat++ & 0xFF;
4278 #ifdef PERL_NATINT_PACK
4279         natint = 0;
4280 #endif
4281         if (isSPACE(datumtype))
4282             continue;
4283         if (*pat == '!') {
4284             char *natstr = "sSiIlL";
4285
4286             if (strchr(natstr, datumtype)) {
4287 #ifdef PERL_NATINT_PACK
4288                 natint = 1;
4289 #endif
4290                 pat++;
4291             }
4292             else
4293                 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
4294         }
4295         if (*pat == '*') {
4296             len = strchr("@Xxu", datumtype) ? 0 : items;
4297             pat++;
4298         }
4299         else if (isDIGIT(*pat)) {
4300             len = *pat++ - '0';
4301             while (isDIGIT(*pat)) {
4302                 len = (len * 10) + (*pat++ - '0');
4303                 if (len < 0)
4304                     Perl_croak(aTHX_ "Repeat count in pack overflows");
4305             }
4306         }
4307         else
4308             len = 1;
4309         if (*pat == '#') {
4310             ++pat;
4311             if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4312                 DIE(aTHX_ "# must be followed by a*, A* or Z*");
4313             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4314                                                    ? *MARK : &PL_sv_no)));
4315         }
4316         switch(datumtype) {
4317         default:
4318             Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4319         case ',': /* grandfather in commas but with a warning */
4320             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4321                 Perl_warner(aTHX_ WARN_UNSAFE,
4322                             "Invalid type in pack: '%c'", (int)datumtype);
4323             break;
4324         case '%':
4325             DIE(aTHX_ "%% may only be used in unpack");
4326         case '@':
4327             len -= SvCUR(cat);
4328             if (len > 0)
4329                 goto grow;
4330             len = -len;
4331             if (len > 0)
4332                 goto shrink;
4333             break;
4334         case 'X':
4335           shrink:
4336             if (SvCUR(cat) < len)
4337                 DIE(aTHX_ "X outside of string");
4338             SvCUR(cat) -= len;
4339             *SvEND(cat) = '\0';
4340             break;
4341         case 'x':
4342           grow:
4343             while (len >= 10) {
4344                 sv_catpvn(cat, null10, 10);
4345                 len -= 10;
4346             }
4347             sv_catpvn(cat, null10, len);
4348             break;
4349         case 'A':
4350         case 'Z':
4351         case 'a':
4352             fromstr = NEXTFROM;
4353             aptr = SvPV(fromstr, fromlen);
4354             if (pat[-1] == '*')
4355                 len = fromlen;
4356             if (fromlen > len)
4357                 sv_catpvn(cat, aptr, len);
4358             else {
4359                 sv_catpvn(cat, aptr, fromlen);
4360                 len -= fromlen;
4361                 if (datumtype == 'A') {
4362                     while (len >= 10) {
4363                         sv_catpvn(cat, space10, 10);
4364                         len -= 10;
4365                     }
4366                     sv_catpvn(cat, space10, len);
4367                 }
4368                 else {
4369                     while (len >= 10) {
4370                         sv_catpvn(cat, null10, 10);
4371                         len -= 10;
4372                     }
4373                     sv_catpvn(cat, null10, len);
4374                 }
4375             }
4376             break;
4377         case 'B':
4378         case 'b':
4379             {
4380                 char *savepat = pat;
4381                 I32 saveitems;
4382
4383                 fromstr = NEXTFROM;
4384                 saveitems = items;
4385                 aptr = SvPV(fromstr, fromlen);
4386                 if (pat[-1] == '*')
4387                     len = fromlen;
4388                 pat = aptr;
4389                 aint = SvCUR(cat);
4390                 SvCUR(cat) += (len+7)/8;
4391                 SvGROW(cat, SvCUR(cat) + 1);
4392                 aptr = SvPVX(cat) + aint;
4393                 if (len > fromlen)
4394                     len = fromlen;
4395                 aint = len;
4396                 items = 0;
4397                 if (datumtype == 'B') {
4398                     for (len = 0; len++ < aint;) {
4399                         items |= *pat++ & 1;
4400                         if (len & 7)
4401                             items <<= 1;
4402                         else {
4403                             *aptr++ = items & 0xff;
4404                             items = 0;
4405                         }
4406                     }
4407                 }
4408                 else {
4409                     for (len = 0; len++ < aint;) {
4410                         if (*pat++ & 1)
4411                             items |= 128;
4412                         if (len & 7)
4413                             items >>= 1;
4414                         else {
4415                             *aptr++ = items & 0xff;
4416                             items = 0;
4417                         }
4418                     }
4419                 }
4420                 if (aint & 7) {
4421                     if (datumtype == 'B')
4422                         items <<= 7 - (aint & 7);
4423                     else
4424                         items >>= 7 - (aint & 7);
4425                     *aptr++ = items & 0xff;
4426                 }
4427                 pat = SvPVX(cat) + SvCUR(cat);
4428                 while (aptr <= pat)
4429                     *aptr++ = '\0';
4430
4431                 pat = savepat;
4432                 items = saveitems;
4433             }
4434             break;
4435         case 'H':
4436         case 'h':
4437             {
4438                 char *savepat = pat;
4439                 I32 saveitems;
4440
4441                 fromstr = NEXTFROM;
4442                 saveitems = items;
4443                 aptr = SvPV(fromstr, fromlen);
4444                 if (pat[-1] == '*')
4445                     len = fromlen;
4446                 pat = aptr;
4447                 aint = SvCUR(cat);
4448                 SvCUR(cat) += (len+1)/2;
4449                 SvGROW(cat, SvCUR(cat) + 1);
4450                 aptr = SvPVX(cat) + aint;
4451                 if (len > fromlen)
4452                     len = fromlen;
4453                 aint = len;
4454                 items = 0;
4455                 if (datumtype == 'H') {
4456                     for (len = 0; len++ < aint;) {
4457                         if (isALPHA(*pat))
4458                             items |= ((*pat++ & 15) + 9) & 15;
4459                         else
4460                             items |= *pat++ & 15;
4461                         if (len & 1)
4462                             items <<= 4;
4463                         else {
4464                             *aptr++ = items & 0xff;
4465                             items = 0;
4466                         }
4467                     }
4468                 }
4469                 else {
4470                     for (len = 0; len++ < aint;) {
4471                         if (isALPHA(*pat))
4472                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4473                         else
4474                             items |= (*pat++ & 15) << 4;
4475                         if (len & 1)
4476                             items >>= 4;
4477                         else {
4478                             *aptr++ = items & 0xff;
4479                             items = 0;
4480                         }
4481                     }
4482                 }
4483                 if (aint & 1)
4484                     *aptr++ = items & 0xff;
4485                 pat = SvPVX(cat) + SvCUR(cat);
4486                 while (aptr <= pat)
4487                     *aptr++ = '\0';
4488
4489                 pat = savepat;
4490                 items = saveitems;
4491             }
4492             break;
4493         case 'C':
4494         case 'c':
4495             while (len-- > 0) {
4496                 fromstr = NEXTFROM;
4497                 aint = SvIV(fromstr);
4498                 achar = aint;
4499                 sv_catpvn(cat, &achar, sizeof(char));
4500             }
4501             break;
4502         case 'U':
4503             while (len-- > 0) {
4504                 fromstr = NEXTFROM;
4505                 auint = SvUV(fromstr);
4506                 SvGROW(cat, SvCUR(cat) + 10);
4507                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4508                                - SvPVX(cat));
4509             }
4510             *SvEND(cat) = '\0';
4511             break;
4512         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4513         case 'f':
4514         case 'F':
4515             while (len-- > 0) {
4516                 fromstr = NEXTFROM;
4517                 afloat = (float)SvNV(fromstr);
4518                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4519             }
4520             break;
4521         case 'd':
4522         case 'D':
4523             while (len-- > 0) {
4524                 fromstr = NEXTFROM;
4525                 adouble = (double)SvNV(fromstr);
4526                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4527             }
4528             break;
4529         case 'n':
4530             while (len-- > 0) {
4531                 fromstr = NEXTFROM;
4532                 ashort = (I16)SvIV(fromstr);
4533 #ifdef HAS_HTONS
4534                 ashort = PerlSock_htons(ashort);
4535 #endif
4536                 CAT16(cat, &ashort);
4537             }
4538             break;
4539         case 'v':
4540             while (len-- > 0) {
4541                 fromstr = NEXTFROM;
4542                 ashort = (I16)SvIV(fromstr);
4543 #ifdef HAS_HTOVS
4544                 ashort = htovs(ashort);
4545 #endif
4546                 CAT16(cat, &ashort);
4547             }
4548             break;
4549         case 'S':
4550 #if SHORTSIZE != SIZE16
4551             if (natint) {
4552                 unsigned short aushort;
4553
4554                 while (len-- > 0) {
4555                     fromstr = NEXTFROM;
4556                     aushort = SvUV(fromstr);
4557                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4558                 }
4559             }
4560             else
4561 #endif
4562             {
4563                 U16 aushort;
4564
4565                 while (len-- > 0) {
4566                     fromstr = NEXTFROM;
4567                     aushort = (U16)SvUV(fromstr);
4568                     CAT16(cat, &aushort);
4569                 }
4570
4571             }
4572             break;
4573         case 's':
4574 #if SHORTSIZE != SIZE16
4575             if (natint) {
4576                 short ashort;
4577
4578                 while (len-- > 0) {
4579                     fromstr = NEXTFROM;
4580                     ashort = SvIV(fromstr);
4581                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4582                 }
4583             }
4584             else
4585 #endif
4586             {
4587                 while (len-- > 0) {
4588                     fromstr = NEXTFROM;
4589                     ashort = (I16)SvIV(fromstr);
4590                     CAT16(cat, &ashort);
4591                 }
4592             }
4593             break;
4594         case 'I':
4595             while (len-- > 0) {
4596                 fromstr = NEXTFROM;
4597                 auint = SvUV(fromstr);
4598                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4599             }
4600             break;
4601         case 'w':
4602             while (len-- > 0) {
4603                 fromstr = NEXTFROM;
4604                 adouble = Perl_floor(SvNV(fromstr));
4605
4606                 if (adouble < 0)
4607                     Perl_croak(aTHX_ "Cannot compress negative numbers");
4608
4609                 if (
4610 #ifdef BW_BITS
4611                     adouble <= BW_MASK
4612 #else
4613 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4614                     adouble <= UV_MAX_cxux
4615 #else
4616                     adouble <= UV_MAX
4617 #endif
4618 #endif
4619                     )
4620                 {
4621                     char   buf[1 + sizeof(UV)];
4622                     char  *in = buf + sizeof(buf);
4623                     UV     auv = U_V(adouble);
4624
4625                     do {
4626                         *--in = (auv & 0x7f) | 0x80;
4627                         auv >>= 7;
4628                     } while (auv);
4629                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4630                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4631                 }
4632                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4633                     char           *from, *result, *in;
4634                     SV             *norm;
4635                     STRLEN          len;
4636                     bool            done;
4637
4638                     /* Copy string and check for compliance */
4639                     from = SvPV(fromstr, len);
4640                     if ((norm = is_an_int(from, len)) == NULL)
4641                         Perl_croak(aTHX_ "can compress only unsigned integer");
4642
4643                     New('w', result, len, char);
4644                     in = result + len;
4645                     done = FALSE;
4646                     while (!done)
4647                         *--in = div128(norm, &done) | 0x80;
4648                     result[len - 1] &= 0x7F; /* clear continue bit */
4649                     sv_catpvn(cat, in, (result + len) - in);
4650                     Safefree(result);
4651                     SvREFCNT_dec(norm); /* free norm */
4652                 }
4653                 else if (SvNOKp(fromstr)) {
4654                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4655                     char  *in = buf + sizeof(buf);
4656
4657                     do {
4658                         double next = floor(adouble / 128);
4659                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4660                         if (--in < buf)  /* this cannot happen ;-) */
4661                             Perl_croak(aTHX_ "Cannot compress integer");
4662                         adouble = next;
4663                     } while (adouble > 0);
4664                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4665                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4666                 }
4667                 else
4668                     Perl_croak(aTHX_ "Cannot compress non integer");
4669             }
4670             break;
4671         case 'i':
4672             while (len-- > 0) {
4673                 fromstr = NEXTFROM;
4674                 aint = SvIV(fromstr);
4675                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4676             }
4677             break;
4678         case 'N':
4679             while (len-- > 0) {
4680                 fromstr = NEXTFROM;
4681                 aulong = SvUV(fromstr);
4682 #ifdef HAS_HTONL
4683                 aulong = PerlSock_htonl(aulong);
4684 #endif
4685                 CAT32(cat, &aulong);
4686             }
4687             break;
4688         case 'V':
4689             while (len-- > 0) {
4690                 fromstr = NEXTFROM;
4691                 aulong = SvUV(fromstr);
4692 #ifdef HAS_HTOVL
4693                 aulong = htovl(aulong);
4694 #endif
4695                 CAT32(cat, &aulong);
4696             }
4697             break;
4698         case 'L':
4699 #if LONGSIZE != SIZE32
4700             if (natint) {
4701                 unsigned long aulong;
4702
4703                 while (len-- > 0) {
4704                     fromstr = NEXTFROM;
4705                     aulong = SvUV(fromstr);
4706                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4707                 }
4708             }
4709             else
4710 #endif
4711             {
4712                 while (len-- > 0) {
4713                     fromstr = NEXTFROM;
4714                     aulong = SvUV(fromstr);
4715                     CAT32(cat, &aulong);
4716                 }
4717             }
4718             break;
4719         case 'l':
4720 #if LONGSIZE != SIZE32
4721             if (natint) {
4722                 long along;
4723
4724                 while (len-- > 0) {
4725                     fromstr = NEXTFROM;
4726                     along = SvIV(fromstr);
4727                     sv_catpvn(cat, (char *)&along, sizeof(long));
4728                 }
4729             }
4730             else
4731 #endif
4732             {
4733                 while (len-- > 0) {
4734                     fromstr = NEXTFROM;
4735                     along = SvIV(fromstr);
4736                     CAT32(cat, &along);
4737                 }
4738             }
4739             break;
4740 #ifdef HAS_QUAD
4741         case 'Q':
4742             while (len-- > 0) {
4743                 fromstr = NEXTFROM;
4744                 auquad = (Uquad_t)SvUV(fromstr);
4745                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4746             }
4747             break;
4748         case 'q':
4749             while (len-- > 0) {
4750                 fromstr = NEXTFROM;
4751                 aquad = (Quad_t)SvIV(fromstr);
4752                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4753             }
4754             break;
4755 #endif /* HAS_QUAD */
4756         case 'P':
4757             len = 1;            /* assume SV is correct length */
4758             /* FALL THROUGH */
4759         case 'p':
4760             while (len-- > 0) {
4761                 fromstr = NEXTFROM;
4762                 if (fromstr == &PL_sv_undef)
4763                     aptr = NULL;
4764                 else {
4765                     STRLEN n_a;
4766                     /* XXX better yet, could spirit away the string to
4767                      * a safe spot and hang on to it until the result
4768                      * of pack() (and all copies of the result) are
4769                      * gone.
4770                      */
4771                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4772                         Perl_warner(aTHX_ WARN_UNSAFE,
4773                                 "Attempt to pack pointer to temporary value");
4774                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4775                         aptr = SvPV(fromstr,n_a);
4776                     else
4777                         aptr = SvPV_force(fromstr,n_a);
4778                 }
4779                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4780             }
4781             break;
4782         case 'u':
4783             fromstr = NEXTFROM;
4784             aptr = SvPV(fromstr, fromlen);
4785             SvGROW(cat, fromlen * 4 / 3);
4786             if (len <= 1)
4787                 len = 45;
4788             else
4789                 len = len / 3 * 3;
4790             while (fromlen > 0) {
4791                 I32 todo;
4792
4793                 if (fromlen > len)
4794                     todo = len;
4795                 else
4796                     todo = fromlen;
4797                 doencodes(cat, aptr, todo);
4798                 fromlen -= todo;
4799                 aptr += todo;
4800             }
4801             break;
4802         }
4803     }
4804     SvSETMAGIC(cat);
4805     SP = ORIGMARK;
4806     PUSHs(cat);
4807     RETURN;
4808 }
4809 #undef NEXTFROM
4810
4811
4812 PP(pp_split)
4813 {
4814     djSP; dTARG;
4815     AV *ary;
4816     register I32 limit = POPi;                  /* note, negative is forever */
4817     SV *sv = POPs;
4818     STRLEN len;
4819     register char *s = SvPV(sv, len);
4820     char *strend = s + len;
4821     register PMOP *pm;
4822     register REGEXP *rx;
4823     register SV *dstr;
4824     register char *m;
4825     I32 iters = 0;
4826     I32 maxiters = (strend - s) + 10;
4827     I32 i;
4828     char *orig;
4829     I32 origlimit = limit;
4830     I32 realarray = 0;
4831     I32 base;
4832     AV *oldstack = PL_curstack;
4833     I32 gimme = GIMME_V;
4834     I32 oldsave = PL_savestack_ix;
4835     I32 make_mortal = 1;
4836     MAGIC *mg = (MAGIC *) NULL;
4837
4838 #ifdef DEBUGGING
4839     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4840 #else
4841     pm = (PMOP*)POPs;
4842 #endif
4843     if (!pm || !s)
4844         DIE(aTHX_ "panic: do_split");
4845     rx = pm->op_pmregexp;
4846
4847     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4848              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4849
4850     if (pm->op_pmreplroot)
4851         ary = GvAVn((GV*)pm->op_pmreplroot);
4852     else if (gimme != G_ARRAY)
4853 #ifdef USE_THREADS
4854         ary = (AV*)PL_curpad[0];
4855 #else
4856         ary = GvAVn(PL_defgv);
4857 #endif /* USE_THREADS */
4858     else
4859         ary = Nullav;
4860     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4861         realarray = 1;
4862         PUTBACK;
4863         av_extend(ary,0);
4864         av_clear(ary);
4865         SPAGAIN;
4866         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4867             PUSHMARK(SP);
4868             XPUSHs(SvTIED_obj((SV*)ary, mg));
4869         }
4870         else {
4871             if (!AvREAL(ary)) {
4872                 AvREAL_on(ary);
4873                 for (i = AvFILLp(ary); i >= 0; i--)
4874                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4875             }
4876             /* temporarily switch stacks */
4877             SWITCHSTACK(PL_curstack, ary);
4878             make_mortal = 0;
4879         }
4880     }
4881     base = SP - PL_stack_base;
4882     orig = s;
4883     if (pm->op_pmflags & PMf_SKIPWHITE) {
4884         if (pm->op_pmflags & PMf_LOCALE) {
4885             while (isSPACE_LC(*s))
4886                 s++;
4887         }
4888         else {
4889             while (isSPACE(*s))
4890                 s++;
4891         }
4892     }
4893     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4894         SAVEINT(PL_multiline);
4895         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4896     }
4897
4898     if (!limit)
4899         limit = maxiters + 2;
4900     if (pm->op_pmflags & PMf_WHITE) {
4901         while (--limit) {
4902             m = s;
4903             while (m < strend &&
4904                    !((pm->op_pmflags & PMf_LOCALE)
4905                      ? isSPACE_LC(*m) : isSPACE(*m)))
4906                 ++m;
4907             if (m >= strend)
4908                 break;
4909
4910             dstr = NEWSV(30, m-s);
4911             sv_setpvn(dstr, s, m-s);
4912             if (make_mortal)
4913                 sv_2mortal(dstr);
4914             XPUSHs(dstr);
4915
4916             s = m + 1;
4917             while (s < strend &&
4918                    ((pm->op_pmflags & PMf_LOCALE)
4919                     ? isSPACE_LC(*s) : isSPACE(*s)))
4920                 ++s;
4921         }
4922     }
4923     else if (strEQ("^", rx->precomp)) {
4924         while (--limit) {
4925             /*SUPPRESS 530*/
4926             for (m = s; m < strend && *m != '\n'; m++) ;
4927             m++;
4928             if (m >= strend)
4929                 break;
4930             dstr = NEWSV(30, m-s);
4931             sv_setpvn(dstr, s, m-s);
4932             if (make_mortal)
4933                 sv_2mortal(dstr);
4934             XPUSHs(dstr);
4935             s = m;
4936         }
4937     }
4938     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
4939              && (rx->reganch & ROPT_CHECK_ALL)
4940              && !(rx->reganch & ROPT_ANCH)) {
4941         int tail = (rx->reganch & RE_INTUIT_TAIL);
4942         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4943         char c;
4944
4945         len = rx->minlen;
4946         if (len == 1 && !tail) {
4947             c = *SvPV(csv,len);
4948             while (--limit) {
4949                 /*SUPPRESS 530*/
4950                 for (m = s; m < strend && *m != c; m++) ;
4951                 if (m >= strend)
4952                     break;
4953                 dstr = NEWSV(30, m-s);
4954                 sv_setpvn(dstr, s, m-s);
4955                 if (make_mortal)
4956                     sv_2mortal(dstr);
4957                 XPUSHs(dstr);
4958                 s = m + 1;
4959             }
4960         }
4961         else {
4962 #ifndef lint
4963             while (s < strend && --limit &&
4964               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4965                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4966 #endif
4967             {
4968                 dstr = NEWSV(31, m-s);
4969                 sv_setpvn(dstr, s, m-s);
4970                 if (make_mortal)
4971                     sv_2mortal(dstr);
4972                 XPUSHs(dstr);
4973                 s = m + len;            /* Fake \n at the end */
4974             }
4975         }
4976     }
4977     else {
4978         maxiters += (strend - s) * rx->nparens;
4979         while (s < strend && --limit
4980 /*             && (!rx->check_substr
4981                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4982                                                  0, NULL))))
4983 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4984                               1 /* minend */, sv, NULL, 0))
4985         {
4986             TAINT_IF(RX_MATCH_TAINTED(rx));
4987             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4988                 m = s;
4989                 s = orig;
4990                 orig = rx->subbeg;
4991                 s = orig + (m - s);
4992                 strend = s + (strend - m);
4993             }
4994             m = rx->startp[0] + orig;
4995             dstr = NEWSV(32, m-s);
4996             sv_setpvn(dstr, s, m-s);
4997             if (make_mortal)
4998                 sv_2mortal(dstr);
4999             XPUSHs(dstr);
5000             if (rx->nparens) {
5001                 for (i = 1; i <= rx->nparens; i++) {
5002                     s = rx->startp[i] + orig;
5003                     m = rx->endp[i] + orig;
5004                     if (m && s) {
5005                         dstr = NEWSV(33, m-s);
5006                         sv_setpvn(dstr, s, m-s);
5007                     }
5008                     else
5009                         dstr = NEWSV(33, 0);
5010                     if (make_mortal)
5011                         sv_2mortal(dstr);
5012                     XPUSHs(dstr);
5013                 }
5014             }
5015             s = rx->endp[0] + orig;
5016         }
5017     }
5018
5019     LEAVE_SCOPE(oldsave);
5020     iters = (SP - PL_stack_base) - base;
5021     if (iters > maxiters)
5022         DIE(aTHX_ "Split loop");
5023
5024     /* keep field after final delim? */
5025     if (s < strend || (iters && origlimit)) {
5026         dstr = NEWSV(34, strend-s);
5027         sv_setpvn(dstr, s, strend-s);
5028         if (make_mortal)
5029             sv_2mortal(dstr);
5030         XPUSHs(dstr);
5031         iters++;
5032     }
5033     else if (!origlimit) {
5034         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5035             iters--, SP--;
5036     }
5037
5038     if (realarray) {
5039         if (!mg) {
5040             SWITCHSTACK(ary, oldstack);
5041             if (SvSMAGICAL(ary)) {
5042                 PUTBACK;
5043                 mg_set((SV*)ary);
5044                 SPAGAIN;
5045             }
5046             if (gimme == G_ARRAY) {
5047                 EXTEND(SP, iters);
5048                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5049                 SP += iters;
5050                 RETURN;
5051             }
5052         }
5053         else {
5054             PUTBACK;
5055             ENTER;
5056             call_method("PUSH",G_SCALAR|G_DISCARD);
5057             LEAVE;
5058             SPAGAIN;
5059             if (gimme == G_ARRAY) {
5060                 /* EXTEND should not be needed - we just popped them */
5061                 EXTEND(SP, iters);
5062                 for (i=0; i < iters; i++) {
5063                     SV **svp = av_fetch(ary, i, FALSE);
5064                     PUSHs((svp) ? *svp : &PL_sv_undef);
5065                 }
5066                 RETURN;
5067             }
5068         }
5069     }
5070     else {
5071         if (gimme == G_ARRAY)
5072             RETURN;
5073     }
5074     if (iters || !pm->op_pmreplroot) {
5075         GETTARGET;
5076         PUSHi(iters);
5077         RETURN;
5078     }
5079     RETPUSHUNDEF;
5080 }
5081
5082 #ifdef USE_THREADS
5083 void
5084 Perl_unlock_condpair(pTHX_ void *svv)
5085 {
5086     dTHR;
5087     MAGIC *mg = mg_find((SV*)svv, 'm');
5088
5089     if (!mg)
5090         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5091     MUTEX_LOCK(MgMUTEXP(mg));
5092     if (MgOWNER(mg) != thr)
5093         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5094     MgOWNER(mg) = 0;
5095     COND_SIGNAL(MgOWNERCONDP(mg));
5096     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5097                           (unsigned long)thr, (unsigned long)svv);)
5098     MUTEX_UNLOCK(MgMUTEXP(mg));
5099 }
5100 #endif /* USE_THREADS */
5101
5102 PP(pp_lock)
5103 {
5104     djSP;
5105     dTOPss;
5106     SV *retsv = sv;
5107 #ifdef USE_THREADS
5108     MAGIC *mg;
5109
5110     if (SvROK(sv))
5111         sv = SvRV(sv);
5112
5113     mg = condpair_magic(sv);
5114     MUTEX_LOCK(MgMUTEXP(mg));
5115     if (MgOWNER(mg) == thr)
5116         MUTEX_UNLOCK(MgMUTEXP(mg));
5117     else {
5118         while (MgOWNER(mg))
5119             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5120         MgOWNER(mg) = thr;
5121         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5122                               (unsigned long)thr, (unsigned long)sv);)
5123         MUTEX_UNLOCK(MgMUTEXP(mg));
5124         SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
5125     }
5126 #endif /* USE_THREADS */
5127     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5128         || SvTYPE(retsv) == SVt_PVCV) {
5129         retsv = refto(retsv);
5130     }
5131     SETs(retsv);
5132     RETURN;
5133 }
5134
5135 PP(pp_threadsv)
5136 {
5137     djSP;
5138 #ifdef USE_THREADS
5139     EXTEND(SP, 1);
5140     if (PL_op->op_private & OPpLVAL_INTRO)
5141         PUSHs(*save_threadsv(PL_op->op_targ));
5142     else
5143         PUSHs(THREADSV(PL_op->op_targ));
5144     RETURN;
5145 #else
5146     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5147 #endif /* USE_THREADS */
5148 }