pp.c

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