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