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 #ifdef OVERLOAD
1365     djSP; tryAMAGICunSET(not);
1366 #endif /* OVERLOAD */
1367     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1368     return NORMAL;
1369 }
1370
1371 PP(pp_complement)
1372 {
1373     djSP; dTARGET; tryAMAGICun(compl);
1374     {
1375       dTOPss;
1376       if (SvNIOKp(sv)) {
1377         if (PL_op->op_private & HINT_INTEGER) {
1378           IBW value = ~SvIV(sv);
1379           SETi(BWi(value));
1380         }
1381         else {
1382           UBW value = ~SvUV(sv);
1383           SETu(BWu(value));
1384         }
1385       }
1386       else {
1387         register char *tmps;
1388         register long *tmpl;
1389         register I32 anum;
1390         STRLEN len;
1391
1392         SvSetSV(TARG, sv);
1393         tmps = SvPV_force(TARG, len);
1394         anum = len;
1395 #ifdef LIBERAL
1396         for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1397             *tmps = ~*tmps;
1398         tmpl = (long*)tmps;
1399         for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1400             *tmpl = ~*tmpl;
1401         tmps = (char*)tmpl;
1402 #endif
1403         for ( ; anum > 0; anum--, tmps++)
1404             *tmps = ~*tmps;
1405
1406         SETs(TARG);
1407       }
1408       RETURN;
1409     }
1410 }
1411
1412 /* integer versions of some of the above */
1413
1414 PP(pp_i_multiply)
1415 {
1416     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1417     {
1418       dPOPTOPiirl;
1419       SETi( left * right );
1420       RETURN;
1421     }
1422 }
1423
1424 PP(pp_i_divide)
1425 {
1426     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1427     {
1428       dPOPiv;
1429       if (value == 0)
1430         DIE("Illegal division by zero");
1431       value = POPi / value;
1432       PUSHi( value );
1433       RETURN;
1434     }
1435 }
1436
1437 PP(pp_i_modulo)
1438 {
1439     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1440     {
1441       dPOPTOPiirl;
1442       if (!right)
1443         DIE("Illegal modulus zero");
1444       SETi( left % right );
1445       RETURN;
1446     }
1447 }
1448
1449 PP(pp_i_add)
1450 {
1451     djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1452     {
1453       dPOPTOPiirl;
1454       SETi( left + right );
1455       RETURN;
1456     }
1457 }
1458
1459 PP(pp_i_subtract)
1460 {
1461     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1462     {
1463       dPOPTOPiirl;
1464       SETi( left - right );
1465       RETURN;
1466     }
1467 }
1468
1469 PP(pp_i_lt)
1470 {
1471     djSP; tryAMAGICbinSET(lt,0);
1472     {
1473       dPOPTOPiirl;
1474       SETs(boolSV(left < right));
1475       RETURN;
1476     }
1477 }
1478
1479 PP(pp_i_gt)
1480 {
1481     djSP; tryAMAGICbinSET(gt,0);
1482     {
1483       dPOPTOPiirl;
1484       SETs(boolSV(left > right));
1485       RETURN;
1486     }
1487 }
1488
1489 PP(pp_i_le)
1490 {
1491     djSP; tryAMAGICbinSET(le,0);
1492     {
1493       dPOPTOPiirl;
1494       SETs(boolSV(left <= right));
1495       RETURN;
1496     }
1497 }
1498
1499 PP(pp_i_ge)
1500 {
1501     djSP; tryAMAGICbinSET(ge,0);
1502     {
1503       dPOPTOPiirl;
1504       SETs(boolSV(left >= right));
1505       RETURN;
1506     }
1507 }
1508
1509 PP(pp_i_eq)
1510 {
1511     djSP; tryAMAGICbinSET(eq,0);
1512     {
1513       dPOPTOPiirl;
1514       SETs(boolSV(left == right));
1515       RETURN;
1516     }
1517 }
1518
1519 PP(pp_i_ne)
1520 {
1521     djSP; tryAMAGICbinSET(ne,0);
1522     {
1523       dPOPTOPiirl;
1524       SETs(boolSV(left != right));
1525       RETURN;
1526     }
1527 }
1528
1529 PP(pp_i_ncmp)
1530 {
1531     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1532     {
1533       dPOPTOPiirl;
1534       I32 value;
1535
1536       if (left > right)
1537         value = 1;
1538       else if (left < right)
1539         value = -1;
1540       else
1541         value = 0;
1542       SETi(value);
1543       RETURN;
1544     }
1545 }
1546
1547 PP(pp_i_negate)
1548 {
1549     djSP; dTARGET; tryAMAGICun(neg);
1550     SETi(-TOPi);
1551     RETURN;
1552 }
1553
1554 /* High falutin' math. */
1555
1556 PP(pp_atan2)
1557 {
1558     djSP; dTARGET; tryAMAGICbin(atan2,0);
1559     {
1560       dPOPTOPnnrl;
1561       SETn(atan2(left, right));
1562       RETURN;
1563     }
1564 }
1565
1566 PP(pp_sin)
1567 {
1568     djSP; dTARGET; tryAMAGICun(sin);
1569     {
1570       double value;
1571       value = POPn;
1572       value = sin(value);
1573       XPUSHn(value);
1574       RETURN;
1575     }
1576 }
1577
1578 PP(pp_cos)
1579 {
1580     djSP; dTARGET; tryAMAGICun(cos);
1581     {
1582       double value;
1583       value = POPn;
1584       value = cos(value);
1585       XPUSHn(value);
1586       RETURN;
1587     }
1588 }
1589
1590 /* Support Configure command-line overrides for rand() functions.
1591    After 5.005, perhaps we should replace this by Configure support
1592    for drand48(), random(), or rand().  For 5.005, though, maintain
1593    compatibility by calling rand() but allow the user to override it.
1594    See INSTALL for details.  --Andy Dougherty  15 July 1998
1595 */
1596 /* Now it's after 5.005, and Configure supports drand48() and random(),
1597    in addition to rand().  So the overrides should not be needed any more.
1598    --Jarkko Hietaniemi  27 September 1998
1599  */
1600
1601 #ifndef HAS_DRAND48_PROTO
1602 extern double drand48 _((void));
1603 #endif
1604
1605 PP(pp_rand)
1606 {
1607     djSP; dTARGET;
1608     double value;
1609     if (MAXARG < 1)
1610         value = 1.0;
1611     else
1612         value = POPn;
1613     if (value == 0.0)
1614         value = 1.0;
1615     if (!PL_srand_called) {
1616         (void)seedDrand01((Rand_seed_t)seed());
1617         PL_srand_called = TRUE;
1618     }
1619     value *= Drand01();
1620     XPUSHn(value);
1621     RETURN;
1622 }
1623
1624 PP(pp_srand)
1625 {
1626     djSP;
1627     UV anum;
1628     if (MAXARG < 1)
1629         anum = seed();
1630     else
1631         anum = POPu;
1632     (void)seedDrand01((Rand_seed_t)anum);
1633     PL_srand_called = TRUE;
1634     EXTEND(SP, 1);
1635     RETPUSHYES;
1636 }
1637
1638 STATIC U32
1639 seed(void)
1640 {
1641     /*
1642      * This is really just a quick hack which grabs various garbage
1643      * values.  It really should be a real hash algorithm which
1644      * spreads the effect of every input bit onto every output bit,
1645      * if someone who knows about such things would bother to write it.
1646      * Might be a good idea to add that function to CORE as well.
1647      * No numbers below come from careful analysis or anything here,
1648      * except they are primes and SEED_C1 > 1E6 to get a full-width
1649      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
1650      * probably be bigger too.
1651      */
1652 #if RANDBITS > 16
1653 #  define SEED_C1       1000003
1654 #define   SEED_C4       73819
1655 #else
1656 #  define SEED_C1       25747
1657 #define   SEED_C4       20639
1658 #endif
1659 #define   SEED_C2       3
1660 #define   SEED_C3       269
1661 #define   SEED_C5       26107
1662
1663     dTHR;
1664 #ifndef PERL_NO_DEV_RANDOM
1665     int fd;
1666 #endif
1667     U32 u;
1668 #ifdef VMS
1669 #  include <starlet.h>
1670     /* when[] = (low 32 bits, high 32 bits) of time since epoch
1671      * in 100-ns units, typically incremented ever 10 ms.        */
1672     unsigned int when[2];
1673 #else
1674 #  ifdef HAS_GETTIMEOFDAY
1675     struct timeval when;
1676 #  else
1677     Time_t when;
1678 #  endif
1679 #endif
1680
1681 /* This test is an escape hatch, this symbol isn't set by Configure. */
1682 #ifndef PERL_NO_DEV_RANDOM
1683 #ifndef PERL_RANDOM_DEVICE
1684    /* /dev/random isn't used by default because reads from it will block
1685     * if there isn't enough entropy available.  You can compile with
1686     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1687     * is enough real entropy to fill the seed. */
1688 #  define PERL_RANDOM_DEVICE "/dev/urandom"
1689 #endif
1690     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1691     if (fd != -1) {
1692         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1693             u = 0;
1694         PerlLIO_close(fd);
1695         if (u)
1696             return u;
1697     }
1698 #endif
1699
1700 #ifdef VMS
1701     _ckvmssts(sys$gettim(when));
1702     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1703 #else
1704 #  ifdef HAS_GETTIMEOFDAY
1705     gettimeofday(&when,(struct timezone *) 0);
1706     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1707 #  else
1708     (void)time(&when);
1709     u = (U32)SEED_C1 * when;
1710 #  endif
1711 #endif
1712     u += SEED_C3 * (U32)getpid();
1713     u += SEED_C4 * (U32)(UV)PL_stack_sp;
1714 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
1715     u += SEED_C5 * (U32)(UV)&when;
1716 #endif
1717     return u;
1718 }
1719
1720 PP(pp_exp)
1721 {
1722     djSP; dTARGET; tryAMAGICun(exp);
1723     {
1724       double value;
1725       value = POPn;
1726       value = exp(value);
1727       XPUSHn(value);
1728       RETURN;
1729     }
1730 }
1731
1732 PP(pp_log)
1733 {
1734     djSP; dTARGET; tryAMAGICun(log);
1735     {
1736       double value;
1737       value = POPn;
1738       if (value <= 0.0) {
1739         SET_NUMERIC_STANDARD();
1740         DIE("Can't take log of %g", value);
1741       }
1742       value = log(value);
1743       XPUSHn(value);
1744       RETURN;
1745     }
1746 }
1747
1748 PP(pp_sqrt)
1749 {
1750     djSP; dTARGET; tryAMAGICun(sqrt);
1751     {
1752       double value;
1753       value = POPn;
1754       if (value < 0.0) {
1755         SET_NUMERIC_STANDARD();
1756         DIE("Can't take sqrt of %g", value);
1757       }
1758       value = sqrt(value);
1759       XPUSHn(value);
1760       RETURN;
1761     }
1762 }
1763
1764 PP(pp_int)
1765 {
1766     djSP; dTARGET;
1767     {
1768       double value = TOPn;
1769       IV iv;
1770
1771       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1772         iv = SvIVX(TOPs);
1773         SETi(iv);
1774       }
1775       else {
1776         if (value >= 0.0)
1777           (void)modf(value, &value);
1778         else {
1779           (void)modf(-value, &value);
1780           value = -value;
1781         }
1782         iv = I_V(value);
1783         if (iv == value)
1784           SETi(iv);
1785         else
1786           SETn(value);
1787       }
1788     }
1789     RETURN;
1790 }
1791
1792 PP(pp_abs)
1793 {
1794     djSP; dTARGET; tryAMAGICun(abs);
1795     {
1796       double value = TOPn;
1797       IV iv;
1798
1799       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1800           (iv = SvIVX(TOPs)) != IV_MIN) {
1801         if (iv < 0)
1802           iv = -iv;
1803         SETi(iv);
1804       }
1805       else {
1806         if (value < 0.0)
1807             value = -value;
1808         SETn(value);
1809       }
1810     }
1811     RETURN;
1812 }
1813
1814 PP(pp_hex)
1815 {
1816     djSP; dTARGET;
1817     char *tmps;
1818     I32 argtype;
1819     STRLEN n_a;
1820
1821     tmps = POPpx;
1822     XPUSHu(scan_hex(tmps, 99, &argtype));
1823     RETURN;
1824 }
1825
1826 PP(pp_oct)
1827 {
1828     djSP; dTARGET;
1829     UV value;
1830     I32 argtype;
1831     char *tmps;
1832     STRLEN n_a;
1833
1834     tmps = POPpx;
1835     while (*tmps && isSPACE(*tmps))
1836         tmps++;
1837     if (*tmps == '0')
1838         tmps++;
1839     if (*tmps == 'x')
1840         value = scan_hex(++tmps, 99, &argtype);
1841     else if (*tmps == 'b')
1842         value = scan_bin(++tmps, 99, &argtype);
1843     else
1844         value = scan_oct(tmps, 99, &argtype);
1845     XPUSHu(value);
1846     RETURN;
1847 }
1848
1849 /* String stuff. */
1850
1851 PP(pp_length)
1852 {
1853     djSP; dTARGET;
1854
1855     if (IN_UTF8) {
1856         SETi( sv_len_utf8(TOPs) );
1857         RETURN;
1858     }
1859
1860     SETi( sv_len(TOPs) );
1861     RETURN;
1862 }
1863
1864 PP(pp_substr)
1865 {
1866     djSP; dTARGET;
1867     SV *sv;
1868     I32 len;
1869     STRLEN curlen;
1870     STRLEN utfcurlen;
1871     I32 pos;
1872     I32 rem;
1873     I32 fail;
1874     I32 lvalue = PL_op->op_flags & OPf_MOD;
1875     char *tmps;
1876     I32 arybase = PL_curcop->cop_arybase;
1877     char *repl = 0;
1878     STRLEN repl_len;
1879
1880     SvTAINTED_off(TARG);                        /* decontaminate */
1881     if (MAXARG > 2) {
1882         if (MAXARG > 3) {
1883             sv = POPs;
1884             repl = SvPV(sv, repl_len);
1885         }
1886         len = POPi;
1887     }
1888     pos = POPi;
1889     sv = POPs;
1890     PUTBACK;
1891     tmps = SvPV(sv, curlen);
1892     if (IN_UTF8) {
1893         utfcurlen = sv_len_utf8(sv);
1894         if (utfcurlen == curlen)
1895             utfcurlen = 0;
1896         else
1897             curlen = utfcurlen;
1898     }
1899     else
1900         utfcurlen = 0;
1901
1902     if (pos >= arybase) {
1903         pos -= arybase;
1904         rem = curlen-pos;
1905         fail = rem;
1906         if (MAXARG > 2) {
1907             if (len < 0) {
1908                 rem += len;
1909                 if (rem < 0)
1910                     rem = 0;
1911             }
1912             else if (rem > len)
1913                      rem = len;
1914         }
1915     }
1916     else {
1917         pos += curlen;
1918         if (MAXARG < 3)
1919             rem = curlen;
1920         else if (len >= 0) {
1921             rem = pos+len;
1922             if (rem > (I32)curlen)
1923                 rem = curlen;
1924         }
1925         else {
1926             rem = curlen+len;
1927             if (rem < pos)
1928                 rem = pos;
1929         }
1930         if (pos < 0)
1931             pos = 0;
1932         fail = rem;
1933         rem -= pos;
1934     }
1935     if (fail < 0) {
1936         if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1937             warner(WARN_SUBSTR, "substr outside of string");
1938         RETPUSHUNDEF;
1939     }
1940     else {
1941         if (utfcurlen)
1942             sv_pos_u2b(sv, &pos, &rem);
1943         tmps += pos;
1944         sv_setpvn(TARG, tmps, rem);
1945         if (lvalue) {                   /* it's an lvalue! */
1946             if (!SvGMAGICAL(sv)) {
1947                 if (SvROK(sv)) {
1948                     STRLEN n_a;
1949                     SvPV_force(sv,n_a);
1950                     if (ckWARN(WARN_SUBSTR))
1951                         warner(WARN_SUBSTR,
1952                                 "Attempt to use reference as lvalue in substr");
1953                 }
1954                 if (SvOK(sv))           /* is it defined ? */
1955                     (void)SvPOK_only(sv);
1956                 else
1957                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1958             }
1959
1960             if (SvTYPE(TARG) < SVt_PVLV) {
1961                 sv_upgrade(TARG, SVt_PVLV);
1962                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1963             }
1964
1965             LvTYPE(TARG) = 'x';
1966             if (LvTARG(TARG) != sv) {
1967                 if (LvTARG(TARG))
1968                     SvREFCNT_dec(LvTARG(TARG));
1969                 LvTARG(TARG) = SvREFCNT_inc(sv);
1970             }
1971             LvTARGOFF(TARG) = pos;
1972             LvTARGLEN(TARG) = rem;
1973         }
1974         else if (repl)
1975             sv_insert(sv, pos, rem, repl, repl_len);
1976     }
1977     SPAGAIN;
1978     PUSHs(TARG);                /* avoid SvSETMAGIC here */
1979     RETURN;
1980 }
1981
1982 PP(pp_vec)
1983 {
1984     djSP; dTARGET;
1985     register I32 size = POPi;
1986     register I32 offset = POPi;
1987     register SV *src = POPs;
1988     I32 lvalue = PL_op->op_flags & OPf_MOD;
1989     STRLEN srclen;
1990     unsigned char *s = (unsigned char*)SvPV(src, srclen);
1991     unsigned long retnum;
1992     I32 len;
1993
1994     SvTAINTED_off(TARG);                        /* decontaminate */
1995     offset *= size;             /* turn into bit offset */
1996     len = (offset + size + 7) / 8;
1997     if (offset < 0 || size < 1)
1998         retnum = 0;
1999     else {
2000         if (lvalue) {                      /* it's an lvalue! */
2001             if (SvTYPE(TARG) < SVt_PVLV) {
2002                 sv_upgrade(TARG, SVt_PVLV);
2003                 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2004             }
2005
2006             LvTYPE(TARG) = 'v';
2007             if (LvTARG(TARG) != src) {
2008                 if (LvTARG(TARG))
2009                     SvREFCNT_dec(LvTARG(TARG));
2010                 LvTARG(TARG) = SvREFCNT_inc(src);
2011             }
2012             LvTARGOFF(TARG) = offset;
2013             LvTARGLEN(TARG) = size;
2014         }
2015         if (len > srclen) {
2016             if (size <= 8)
2017                 retnum = 0;
2018             else {
2019                 offset >>= 3;
2020                 if (size == 16) {
2021                     if (offset >= srclen)
2022                         retnum = 0;
2023                     else
2024                         retnum = (unsigned long) s[offset] << 8;
2025                 }
2026                 else if (size == 32) {
2027                     if (offset >= srclen)
2028                         retnum = 0;
2029                     else if (offset + 1 >= srclen)
2030                         retnum = (unsigned long) s[offset] << 24;
2031                     else if (offset + 2 >= srclen)
2032                         retnum = ((unsigned long) s[offset] << 24) +
2033                             ((unsigned long) s[offset + 1] << 16);
2034                     else
2035                         retnum = ((unsigned long) s[offset] << 24) +
2036                             ((unsigned long) s[offset + 1] << 16) +
2037                             (s[offset + 2] << 8);
2038                 }
2039             }
2040         }
2041         else if (size < 8)
2042             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2043         else {
2044             offset >>= 3;
2045             if (size == 8)
2046                 retnum = s[offset];
2047             else if (size == 16)
2048                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2049             else if (size == 32)
2050                 retnum = ((unsigned long) s[offset] << 24) +
2051                         ((unsigned long) s[offset + 1] << 16) +
2052                         (s[offset + 2] << 8) + s[offset+3];
2053         }
2054     }
2055
2056     sv_setuv(TARG, (UV)retnum);
2057     PUSHs(TARG);
2058     RETURN;
2059 }
2060
2061 PP(pp_index)
2062 {
2063     djSP; dTARGET;
2064     SV *big;
2065     SV *little;
2066     I32 offset;
2067     I32 retval;
2068     char *tmps;
2069     char *tmps2;
2070     STRLEN biglen;
2071     I32 arybase = PL_curcop->cop_arybase;
2072
2073     if (MAXARG < 3)
2074         offset = 0;
2075     else
2076         offset = POPi - arybase;
2077     little = POPs;
2078     big = POPs;
2079     tmps = SvPV(big, biglen);
2080     if (IN_UTF8 && offset > 0)
2081         sv_pos_u2b(big, &offset, 0);
2082     if (offset < 0)
2083         offset = 0;
2084     else if (offset > biglen)
2085         offset = biglen;
2086     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2087       (unsigned char*)tmps + biglen, little, 0)))
2088         retval = -1;
2089     else
2090         retval = tmps2 - tmps;
2091     if (IN_UTF8 && retval > 0)
2092         sv_pos_b2u(big, &retval);
2093     PUSHi(retval + arybase);
2094     RETURN;
2095 }
2096
2097 PP(pp_rindex)
2098 {
2099     djSP; dTARGET;
2100     SV *big;
2101     SV *little;
2102     STRLEN blen;
2103     STRLEN llen;
2104     I32 offset;
2105     I32 retval;
2106     char *tmps;
2107     char *tmps2;
2108     I32 arybase = PL_curcop->cop_arybase;
2109
2110     if (MAXARG >= 3)
2111         offset = POPi;
2112     little = POPs;
2113     big = POPs;
2114     tmps2 = SvPV(little, llen);
2115     tmps = SvPV(big, blen);
2116     if (MAXARG < 3)
2117         offset = blen;
2118     else {
2119         if (IN_UTF8 && offset > 0)
2120             sv_pos_u2b(big, &offset, 0);
2121         offset = offset - arybase + llen;
2122     }
2123     if (offset < 0)
2124         offset = 0;
2125     else if (offset > blen)
2126         offset = blen;
2127     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2128                           tmps2, tmps2 + llen)))
2129         retval = -1;
2130     else
2131         retval = tmps2 - tmps;
2132     if (IN_UTF8 && retval > 0)
2133         sv_pos_b2u(big, &retval);
2134     PUSHi(retval + arybase);
2135     RETURN;
2136 }
2137
2138 PP(pp_sprintf)
2139 {
2140     djSP; dMARK; dORIGMARK; dTARGET;
2141 #ifdef USE_LOCALE_NUMERIC
2142     if (PL_op->op_private & OPpLOCALE)
2143         SET_NUMERIC_LOCAL();
2144     else
2145         SET_NUMERIC_STANDARD();
2146 #endif
2147     do_sprintf(TARG, SP-MARK, MARK+1);
2148     TAINT_IF(SvTAINTED(TARG));
2149     SP = ORIGMARK;
2150     PUSHTARG;
2151     RETURN;
2152 }
2153
2154 PP(pp_ord)
2155 {
2156     djSP; dTARGET;
2157     UV value;
2158     STRLEN n_a;
2159     U8 *tmps = (U8*)POPpx;
2160     I32 retlen;
2161
2162     if (IN_UTF8 && (*tmps & 0x80))
2163         value = utf8_to_uv(tmps, &retlen);
2164     else
2165         value = (UV)(*tmps & 255);
2166     XPUSHu(value);
2167     RETURN;
2168 }
2169
2170 PP(pp_chr)
2171 {
2172     djSP; dTARGET;
2173     char *tmps;
2174     U32 value = POPu;
2175
2176     (void)SvUPGRADE(TARG,SVt_PV);
2177
2178     if (IN_UTF8 && value >= 128) {
2179         SvGROW(TARG,8);
2180         tmps = SvPVX(TARG);
2181         tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2182         SvCUR_set(TARG, tmps - SvPVX(TARG));
2183         *tmps = '\0';
2184         (void)SvPOK_only(TARG);
2185         XPUSHs(TARG);
2186         RETURN;
2187     }
2188
2189     SvGROW(TARG,2);
2190     SvCUR_set(TARG, 1);
2191     tmps = SvPVX(TARG);
2192     *tmps++ = value;
2193     *tmps = '\0';
2194     (void)SvPOK_only(TARG);
2195     XPUSHs(TARG);
2196     RETURN;
2197 }
2198
2199 PP(pp_crypt)
2200 {
2201     djSP; dTARGET; dPOPTOPssrl;
2202     STRLEN n_a;
2203 #ifdef HAS_CRYPT
2204     char *tmps = SvPV(left, n_a);
2205 #ifdef FCRYPT
2206     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2207 #else
2208     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2209 #endif
2210 #else
2211     DIE(
2212       "The crypt() function is unimplemented due to excessive paranoia.");
2213 #endif
2214     SETs(TARG);
2215     RETURN;
2216 }
2217
2218 PP(pp_ucfirst)
2219 {
2220     djSP;
2221     SV *sv = TOPs;
2222     register U8 *s;
2223     STRLEN slen;
2224
2225     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2226         I32 ulen;
2227         U8 tmpbuf[10];
2228         U8 *tend;
2229         UV uv = utf8_to_uv(s, &ulen);
2230
2231         if (PL_op->op_private & OPpLOCALE) {
2232             TAINT;
2233             SvTAINTED_on(sv);
2234             uv = toTITLE_LC_uni(uv);
2235         }
2236         else
2237             uv = toTITLE_utf8(s);
2238
2239         tend = uv_to_utf8(tmpbuf, uv);
2240
2241         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2242             dTARGET;
2243             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2244             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2245             SETs(TARG);
2246         }
2247         else {
2248             s = (U8*)SvPV_force(sv, slen);
2249             Copy(tmpbuf, s, ulen, U8);
2250         }
2251         RETURN;
2252     }
2253
2254     if (!SvPADTMP(sv)) {
2255         dTARGET;
2256         sv_setsv(TARG, sv);
2257         sv = TARG;
2258         SETs(sv);
2259     }
2260     s = (U8*)SvPV_force(sv, slen);
2261     if (*s) {
2262         if (PL_op->op_private & OPpLOCALE) {
2263             TAINT;
2264             SvTAINTED_on(sv);
2265             *s = toUPPER_LC(*s);
2266         }
2267         else
2268             *s = toUPPER(*s);
2269     }
2270
2271     RETURN;
2272 }
2273
2274 PP(pp_lcfirst)
2275 {
2276     djSP;
2277     SV *sv = TOPs;
2278     register U8 *s;
2279     STRLEN slen;
2280
2281     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2282         I32 ulen;
2283         U8 tmpbuf[10];
2284         U8 *tend;
2285         UV uv = utf8_to_uv(s, &ulen);
2286
2287         if (PL_op->op_private & OPpLOCALE) {
2288             TAINT;
2289             SvTAINTED_on(sv);
2290             uv = toLOWER_LC_uni(uv);
2291         }
2292         else
2293             uv = toLOWER_utf8(s);
2294
2295         tend = uv_to_utf8(tmpbuf, uv);
2296
2297         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2298             dTARGET;
2299             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2300             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2301             SETs(TARG);
2302         }
2303         else {
2304             s = (U8*)SvPV_force(sv, slen);
2305             Copy(tmpbuf, s, ulen, U8);
2306         }
2307         RETURN;
2308     }
2309
2310     if (!SvPADTMP(sv)) {
2311         dTARGET;
2312         sv_setsv(TARG, sv);
2313         sv = TARG;
2314         SETs(sv);
2315     }
2316     s = (U8*)SvPV_force(sv, slen);
2317     if (*s) {
2318         if (PL_op->op_private & OPpLOCALE) {
2319             TAINT;
2320             SvTAINTED_on(sv);
2321             *s = toLOWER_LC(*s);
2322         }
2323         else
2324             *s = toLOWER(*s);
2325     }
2326
2327     SETs(sv);
2328     RETURN;
2329 }
2330
2331 PP(pp_uc)
2332 {
2333     djSP;
2334     SV *sv = TOPs;
2335     register U8 *s;
2336     STRLEN len;
2337
2338     if (IN_UTF8) {
2339         dTARGET;
2340         I32 ulen;
2341         register U8 *d;
2342         U8 *send;
2343
2344         s = (U8*)SvPV(sv,len);
2345         if (!len) {
2346             sv_setpvn(TARG, "", 0);
2347             SETs(TARG);
2348             RETURN;
2349         }
2350
2351         (void)SvUPGRADE(TARG, SVt_PV);
2352         SvGROW(TARG, (len * 2) + 1);
2353         (void)SvPOK_only(TARG);
2354         d = (U8*)SvPVX(TARG);
2355         send = s + len;
2356         if (PL_op->op_private & OPpLOCALE) {
2357             TAINT;
2358             SvTAINTED_on(TARG);
2359             while (s < send) {
2360                 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2361                 s += ulen;
2362             }
2363         }
2364         else {
2365             while (s < send) {
2366                 d = uv_to_utf8(d, toUPPER_utf8( s ));
2367                 s += UTF8SKIP(s);
2368             }
2369         }
2370         *d = '\0';
2371         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2372         SETs(TARG);
2373         RETURN;
2374     }
2375
2376     if (!SvPADTMP(sv)) {
2377         dTARGET;
2378         sv_setsv(TARG, sv);
2379         sv = TARG;
2380         SETs(sv);
2381     }
2382
2383     s = (U8*)SvPV_force(sv, len);
2384     if (len) {
2385         register U8 *send = s + len;
2386
2387         if (PL_op->op_private & OPpLOCALE) {
2388             TAINT;
2389             SvTAINTED_on(sv);
2390             for (; s < send; s++)
2391                 *s = toUPPER_LC(*s);
2392         }
2393         else {
2394             for (; s < send; s++)
2395                 *s = toUPPER(*s);
2396         }
2397     }
2398     RETURN;
2399 }
2400
2401 PP(pp_lc)
2402 {
2403     djSP;
2404     SV *sv = TOPs;
2405     register U8 *s;
2406     STRLEN len;
2407
2408     if (IN_UTF8) {
2409         dTARGET;
2410         I32 ulen;
2411         register U8 *d;
2412         U8 *send;
2413
2414         s = (U8*)SvPV(sv,len);
2415         if (!len) {
2416             sv_setpvn(TARG, "", 0);
2417             SETs(TARG);
2418             RETURN;
2419         }
2420
2421         (void)SvUPGRADE(TARG, SVt_PV);
2422         SvGROW(TARG, (len * 2) + 1);
2423         (void)SvPOK_only(TARG);
2424         d = (U8*)SvPVX(TARG);
2425         send = s + len;
2426         if (PL_op->op_private & OPpLOCALE) {
2427             TAINT;
2428             SvTAINTED_on(TARG);
2429             while (s < send) {
2430                 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2431                 s += ulen;
2432             }
2433         }
2434         else {
2435             while (s < send) {
2436                 d = uv_to_utf8(d, toLOWER_utf8(s));
2437                 s += UTF8SKIP(s);
2438             }
2439         }
2440         *d = '\0';
2441         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2442         SETs(TARG);
2443         RETURN;
2444     }
2445
2446     if (!SvPADTMP(sv)) {
2447         dTARGET;
2448         sv_setsv(TARG, sv);
2449         sv = TARG;
2450         SETs(sv);
2451     }
2452
2453     s = (U8*)SvPV_force(sv, len);
2454     if (len) {
2455         register U8 *send = s + len;
2456
2457         if (PL_op->op_private & OPpLOCALE) {
2458             TAINT;
2459             SvTAINTED_on(sv);
2460             for (; s < send; s++)
2461                 *s = toLOWER_LC(*s);
2462         }
2463         else {
2464             for (; s < send; s++)
2465                 *s = toLOWER(*s);
2466         }
2467     }
2468     RETURN;
2469 }
2470
2471 PP(pp_quotemeta)
2472 {
2473     djSP; dTARGET;
2474     SV *sv = TOPs;
2475     STRLEN len;
2476     register char *s = SvPV(sv,len);
2477     register char *d;
2478
2479     if (len) {
2480         (void)SvUPGRADE(TARG, SVt_PV);
2481         SvGROW(TARG, (len * 2) + 1);
2482         d = SvPVX(TARG);
2483         if (IN_UTF8) {
2484             while (len) {
2485                 if (*s & 0x80) {
2486                     STRLEN ulen = UTF8SKIP(s);
2487                     if (ulen > len)
2488                         ulen = len;
2489                     len -= ulen;
2490                     while (ulen--)
2491                         *d++ = *s++;
2492                 }
2493                 else {
2494                     if (!isALNUM(*s))
2495                         *d++ = '\\';
2496                     *d++ = *s++;
2497                     len--;
2498                 }
2499             }
2500         }
2501         else {
2502             while (len--) {
2503                 if (!isALNUM(*s))
2504                     *d++ = '\\';
2505                 *d++ = *s++;
2506             }
2507         }
2508         *d = '\0';
2509         SvCUR_set(TARG, d - SvPVX(TARG));
2510         (void)SvPOK_only(TARG);
2511     }
2512     else
2513         sv_setpvn(TARG, s, len);
2514     SETs(TARG);
2515     RETURN;
2516 }
2517
2518 /* Arrays. */
2519
2520 PP(pp_aslice)
2521 {
2522     djSP; dMARK; dORIGMARK;
2523     register SV** svp;
2524     register AV* av = (AV*)POPs;
2525     register I32 lval = PL_op->op_flags & OPf_MOD;
2526     I32 arybase = PL_curcop->cop_arybase;
2527     I32 elem;
2528
2529     if (SvTYPE(av) == SVt_PVAV) {
2530         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2531             I32 max = -1;
2532             for (svp = MARK + 1; svp <= SP; svp++) {
2533                 elem = SvIVx(*svp);
2534                 if (elem > max)
2535                     max = elem;
2536             }
2537             if (max > AvMAX(av))
2538                 av_extend(av, max);
2539         }
2540         while (++MARK <= SP) {
2541             elem = SvIVx(*MARK);
2542
2543             if (elem > 0)
2544                 elem -= arybase;
2545             svp = av_fetch(av, elem, lval);
2546             if (lval) {
2547                 if (!svp || *svp == &PL_sv_undef)
2548                     DIE(PL_no_aelem, elem);
2549                 if (PL_op->op_private & OPpLVAL_INTRO)
2550                     save_aelem(av, elem, svp);
2551             }
2552             *MARK = svp ? *svp : &PL_sv_undef;
2553         }
2554     }
2555     if (GIMME != G_ARRAY) {
2556         MARK = ORIGMARK;
2557         *++MARK = *SP;
2558         SP = MARK;
2559     }
2560     RETURN;
2561 }
2562
2563 /* Associative arrays. */
2564
2565 PP(pp_each)
2566 {
2567     djSP; dTARGET;
2568     HV *hash = (HV*)POPs;
2569     HE *entry;
2570     I32 gimme = GIMME_V;
2571     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2572
2573     PUTBACK;
2574     /* might clobber stack_sp */
2575     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2576     SPAGAIN;
2577
2578     EXTEND(SP, 2);
2579     if (entry) {
2580         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2581         if (gimme == G_ARRAY) {
2582             PUTBACK;
2583             /* might clobber stack_sp */
2584             sv_setsv(TARG, realhv ?
2585                      hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2586             SPAGAIN;
2587             PUSHs(TARG);
2588         }
2589     }
2590     else if (gimme == G_SCALAR)
2591         RETPUSHUNDEF;
2592
2593     RETURN;
2594 }
2595
2596 PP(pp_values)
2597 {
2598     return do_kv(ARGS);
2599 }
2600
2601 PP(pp_keys)
2602 {
2603     return do_kv(ARGS);
2604 }
2605
2606 PP(pp_delete)
2607 {
2608     djSP;
2609     I32 gimme = GIMME_V;
2610     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2611     SV *sv;
2612     HV *hv;
2613
2614     if (PL_op->op_private & OPpSLICE) {
2615         dMARK; dORIGMARK;
2616         U32 hvtype;
2617         hv = (HV*)POPs;
2618         hvtype = SvTYPE(hv);
2619         while (++MARK <= SP) {
2620             if (hvtype == SVt_PVHV)
2621                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2622             else
2623                 DIE("Not a HASH reference");
2624             *MARK = sv ? sv : &PL_sv_undef;
2625         }
2626         if (discard)
2627             SP = ORIGMARK;
2628         else if (gimme == G_SCALAR) {
2629             MARK = ORIGMARK;
2630             *++MARK = *SP;
2631             SP = MARK;
2632         }
2633     }
2634     else {
2635         SV *keysv = POPs;
2636         hv = (HV*)POPs;
2637         if (SvTYPE(hv) == SVt_PVHV)
2638             sv = hv_delete_ent(hv, keysv, discard, 0);
2639         else
2640             DIE("Not a HASH reference");
2641         if (!sv)
2642             sv = &PL_sv_undef;
2643         if (!discard)
2644             PUSHs(sv);
2645     }
2646     RETURN;
2647 }
2648
2649 PP(pp_exists)
2650 {
2651     djSP;
2652     SV *tmpsv = POPs;
2653     HV *hv = (HV*)POPs;
2654     if (SvTYPE(hv) == SVt_PVHV) {
2655         if (hv_exists_ent(hv, tmpsv, 0))
2656             RETPUSHYES;
2657     } else if (SvTYPE(hv) == SVt_PVAV) {
2658         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2659             RETPUSHYES;
2660     } else {
2661         DIE("Not a HASH reference");
2662     }
2663     RETPUSHNO;
2664 }
2665
2666 PP(pp_hslice)
2667 {
2668     djSP; dMARK; dORIGMARK;
2669     register HV *hv = (HV*)POPs;
2670     register I32 lval = PL_op->op_flags & OPf_MOD;
2671     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2672
2673     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2674         DIE("Can't localize pseudo-hash element");
2675
2676     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2677         while (++MARK <= SP) {
2678             SV *keysv = *MARK;
2679             SV **svp;
2680             if (realhv) {
2681                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2682                 svp = he ? &HeVAL(he) : 0;
2683             } else {
2684                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2685             }
2686             if (lval) {
2687                 if (!svp || *svp == &PL_sv_undef) {
2688                     STRLEN n_a;
2689                     DIE(PL_no_helem, SvPV(keysv, n_a));
2690                 }
2691                 if (PL_op->op_private & OPpLVAL_INTRO)
2692                     save_helem(hv, keysv, svp);
2693             }
2694             *MARK = svp ? *svp : &PL_sv_undef;
2695         }
2696     }
2697     if (GIMME != G_ARRAY) {
2698         MARK = ORIGMARK;
2699         *++MARK = *SP;
2700         SP = MARK;
2701     }
2702     RETURN;
2703 }
2704
2705 /* List operators. */
2706
2707 PP(pp_list)
2708 {
2709     djSP; dMARK;
2710     if (GIMME != G_ARRAY) {
2711         if (++MARK <= SP)
2712             *MARK = *SP;                /* unwanted list, return last item */
2713         else
2714             *MARK = &PL_sv_undef;
2715         SP = MARK;
2716     }
2717     RETURN;
2718 }
2719
2720 PP(pp_lslice)
2721 {
2722     djSP;
2723     SV **lastrelem = PL_stack_sp;
2724     SV **lastlelem = PL_stack_base + POPMARK;
2725     SV **firstlelem = PL_stack_base + POPMARK + 1;
2726     register SV **firstrelem = lastlelem + 1;
2727     I32 arybase = PL_curcop->cop_arybase;
2728     I32 lval = PL_op->op_flags & OPf_MOD;
2729     I32 is_something_there = lval;
2730
2731     register I32 max = lastrelem - lastlelem;
2732     register SV **lelem;
2733     register I32 ix;
2734
2735     if (GIMME != G_ARRAY) {
2736         ix = SvIVx(*lastlelem);
2737         if (ix < 0)
2738             ix += max;
2739         else
2740             ix -= arybase;
2741         if (ix < 0 || ix >= max)
2742             *firstlelem = &PL_sv_undef;
2743         else
2744             *firstlelem = firstrelem[ix];
2745         SP = firstlelem;
2746         RETURN;
2747     }
2748
2749     if (max == 0) {
2750         SP = firstlelem - 1;
2751         RETURN;
2752     }
2753
2754     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2755         ix = SvIVx(*lelem);
2756         if (ix < 0) {
2757             ix += max;
2758             if (ix < 0)
2759                 *lelem = &PL_sv_undef;
2760             else if (!(*lelem = firstrelem[ix]))
2761                 *lelem = &PL_sv_undef;
2762         }
2763         else {
2764             ix -= arybase;
2765             if (ix >= max || !(*lelem = firstrelem[ix]))
2766                 *lelem = &PL_sv_undef;
2767         }
2768         if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2769             is_something_there = TRUE;
2770     }
2771     if (is_something_there)
2772         SP = lastlelem;
2773     else
2774         SP = firstlelem - 1;
2775     RETURN;
2776 }
2777
2778 PP(pp_anonlist)
2779 {
2780     djSP; dMARK; dORIGMARK;
2781     I32 items = SP - MARK;
2782     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2783     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2784     XPUSHs(av);
2785     RETURN;
2786 }
2787
2788 PP(pp_anonhash)
2789 {
2790     djSP; dMARK; dORIGMARK;
2791     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2792
2793     while (MARK < SP) {
2794         SV* key = *++MARK;
2795         SV *val = NEWSV(46, 0);
2796         if (MARK < SP)
2797             sv_setsv(val, *++MARK);
2798         else if (ckWARN(WARN_UNSAFE))
2799             warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2800         (void)hv_store_ent(hv,key,val,0);
2801     }
2802     SP = ORIGMARK;
2803     XPUSHs((SV*)hv);
2804     RETURN;
2805 }
2806
2807 PP(pp_splice)
2808 {
2809     djSP; dMARK; dORIGMARK;
2810     register AV *ary = (AV*)*++MARK;
2811     register SV **src;
2812     register SV **dst;
2813     register I32 i;
2814     register I32 offset;
2815     register I32 length;
2816     I32 newlen;
2817     I32 after;
2818     I32 diff;
2819     SV **tmparyval = 0;
2820     MAGIC *mg;
2821
2822     if (mg = SvTIED_mg((SV*)ary, 'P')) {
2823         *MARK-- = SvTIED_obj((SV*)ary, mg);
2824         PUSHMARK(MARK);
2825         PUTBACK;
2826         ENTER;
2827         perl_call_method("SPLICE",GIMME_V);
2828         LEAVE;
2829         SPAGAIN;
2830         RETURN;
2831     }
2832
2833     SP++;
2834
2835     if (++MARK < SP) {
2836         offset = i = SvIVx(*MARK);
2837         if (offset < 0)
2838             offset += AvFILLp(ary) + 1;
2839         else
2840             offset -= PL_curcop->cop_arybase;
2841         if (offset < 0)
2842             DIE(PL_no_aelem, i);
2843         if (++MARK < SP) {
2844             length = SvIVx(*MARK++);
2845             if (length < 0) {
2846                 length += AvFILLp(ary) - offset + 1;
2847                 if (length < 0)
2848                     length = 0;
2849             }
2850         }
2851         else
2852             length = AvMAX(ary) + 1;            /* close enough to infinity */
2853     }
2854     else {
2855         offset = 0;
2856         length = AvMAX(ary) + 1;
2857     }
2858     if (offset > AvFILLp(ary) + 1)
2859         offset = AvFILLp(ary) + 1;
2860     after = AvFILLp(ary) + 1 - (offset + length);
2861     if (after < 0) {                            /* not that much array */
2862         length += after;                        /* offset+length now in array */
2863         after = 0;
2864         if (!AvALLOC(ary))
2865             av_extend(ary, 0);
2866     }
2867
2868     /* At this point, MARK .. SP-1 is our new LIST */
2869
2870     newlen = SP - MARK;
2871     diff = newlen - length;
2872     if (newlen && !AvREAL(ary) && AvREIFY(ary))
2873         av_reify(ary);
2874
2875     if (diff < 0) {                             /* shrinking the area */
2876         if (newlen) {
2877             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2878             Copy(MARK, tmparyval, newlen, SV*);
2879         }
2880
2881         MARK = ORIGMARK + 1;
2882         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2883             MEXTEND(MARK, length);
2884             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2885             if (AvREAL(ary)) {
2886                 EXTEND_MORTAL(length);
2887                 for (i = length, dst = MARK; i; i--) {
2888                     sv_2mortal(*dst);   /* free them eventualy */
2889                     dst++;
2890                 }
2891             }
2892             MARK += length - 1;
2893         }
2894         else {
2895             *MARK = AvARRAY(ary)[offset+length-1];
2896             if (AvREAL(ary)) {
2897                 sv_2mortal(*MARK);
2898                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2899                     SvREFCNT_dec(*dst++);       /* free them now */
2900             }
2901         }
2902         AvFILLp(ary) += diff;
2903
2904         /* pull up or down? */
2905
2906         if (offset < after) {                   /* easier to pull up */
2907             if (offset) {                       /* esp. if nothing to pull */
2908                 src = &AvARRAY(ary)[offset-1];
2909                 dst = src - diff;               /* diff is negative */
2910                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2911                     *dst-- = *src--;
2912             }
2913             dst = AvARRAY(ary);
2914             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2915             AvMAX(ary) += diff;
2916         }
2917         else {
2918             if (after) {                        /* anything to pull down? */
2919                 src = AvARRAY(ary) + offset + length;
2920                 dst = src + diff;               /* diff is negative */
2921                 Move(src, dst, after, SV*);
2922             }
2923             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2924                                                 /* avoid later double free */
2925         }
2926         i = -diff;
2927         while (i)
2928             dst[--i] = &PL_sv_undef;
2929
2930         if (newlen) {
2931             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2932               newlen; newlen--) {
2933                 *dst = NEWSV(46, 0);
2934                 sv_setsv(*dst++, *src++);
2935             }
2936             Safefree(tmparyval);
2937         }
2938     }
2939     else {                                      /* no, expanding (or same) */
2940         if (length) {
2941             New(452, tmparyval, length, SV*);   /* so remember deletion */
2942             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2943         }
2944
2945         if (diff > 0) {                         /* expanding */
2946
2947             /* push up or down? */
2948
2949             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2950                 if (offset) {
2951                     src = AvARRAY(ary);
2952                     dst = src - diff;
2953                     Move(src, dst, offset, SV*);
2954                 }
2955                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2956                 AvMAX(ary) += diff;
2957                 AvFILLp(ary) += diff;
2958             }
2959             else {
2960                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2961                     av_extend(ary, AvFILLp(ary) + diff);
2962                 AvFILLp(ary) += diff;
2963
2964                 if (after) {
2965                     dst = AvARRAY(ary) + AvFILLp(ary);
2966                     src = dst - diff;
2967                     for (i = after; i; i--) {
2968                         *dst-- = *src--;
2969                     }
2970                 }
2971             }
2972         }
2973
2974         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2975             *dst = NEWSV(46, 0);
2976             sv_setsv(*dst++, *src++);
2977         }
2978         MARK = ORIGMARK + 1;
2979         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2980             if (length) {
2981                 Copy(tmparyval, MARK, length, SV*);
2982                 if (AvREAL(ary)) {
2983                     EXTEND_MORTAL(length);
2984                     for (i = length, dst = MARK; i; i--) {
2985                         sv_2mortal(*dst);       /* free them eventualy */
2986                         dst++;
2987                     }
2988                 }
2989                 Safefree(tmparyval);
2990             }
2991             MARK += length - 1;
2992         }
2993         else if (length--) {
2994             *MARK = tmparyval[length];
2995             if (AvREAL(ary)) {
2996                 sv_2mortal(*MARK);
2997                 while (length-- > 0)
2998                     SvREFCNT_dec(tmparyval[length]);
2999             }
3000             Safefree(tmparyval);
3001         }
3002         else
3003             *MARK = &PL_sv_undef;
3004     }
3005     SP = MARK;
3006     RETURN;
3007 }
3008
3009 PP(pp_push)
3010 {
3011     djSP; dMARK; dORIGMARK; dTARGET;
3012     register AV *ary = (AV*)*++MARK;
3013     register SV *sv = &PL_sv_undef;
3014     MAGIC *mg;
3015
3016     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3017         *MARK-- = SvTIED_obj((SV*)ary, mg);
3018         PUSHMARK(MARK);
3019         PUTBACK;
3020         ENTER;
3021         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3022         LEAVE;
3023         SPAGAIN;
3024     }
3025     else {
3026         /* Why no pre-extend of ary here ? */
3027         for (++MARK; MARK <= SP; MARK++) {
3028             sv = NEWSV(51, 0);
3029             if (*MARK)
3030                 sv_setsv(sv, *MARK);
3031             av_push(ary, sv);
3032         }
3033     }
3034     SP = ORIGMARK;
3035     PUSHi( AvFILL(ary) + 1 );
3036     RETURN;
3037 }
3038
3039 PP(pp_pop)
3040 {
3041     djSP;
3042     AV *av = (AV*)POPs;
3043     SV *sv = av_pop(av);
3044     if (AvREAL(av))
3045         (void)sv_2mortal(sv);
3046     PUSHs(sv);
3047     RETURN;
3048 }
3049
3050 PP(pp_shift)
3051 {
3052     djSP;
3053     AV *av = (AV*)POPs;
3054     SV *sv = av_shift(av);
3055     EXTEND(SP, 1);
3056     if (!sv)
3057         RETPUSHUNDEF;
3058     if (AvREAL(av))
3059         (void)sv_2mortal(sv);
3060     PUSHs(sv);
3061     RETURN;
3062 }
3063
3064 PP(pp_unshift)
3065 {
3066     djSP; dMARK; dORIGMARK; dTARGET;
3067     register AV *ary = (AV*)*++MARK;
3068     register SV *sv;
3069     register I32 i = 0;
3070     MAGIC *mg;
3071
3072     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3073         *MARK-- = SvTIED_obj((SV*)ary, mg);
3074         PUSHMARK(MARK);
3075         PUTBACK;
3076         ENTER;
3077         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3078         LEAVE;
3079         SPAGAIN;
3080     }
3081     else {
3082         av_unshift(ary, SP - MARK);
3083         while (MARK < SP) {
3084             sv = NEWSV(27, 0);
3085             sv_setsv(sv, *++MARK);
3086             (void)av_store(ary, i++, sv);
3087         }
3088     }
3089     SP = ORIGMARK;
3090     PUSHi( AvFILL(ary) + 1 );
3091     RETURN;
3092 }
3093
3094 PP(pp_reverse)
3095 {
3096     djSP; dMARK;
3097     register SV *tmp;
3098     SV **oldsp = SP;
3099
3100     if (GIMME == G_ARRAY) {
3101         MARK++;
3102         while (MARK < SP) {
3103             tmp = *MARK;
3104             *MARK++ = *SP;
3105             *SP-- = tmp;
3106         }
3107         SP = oldsp;
3108     }
3109     else {
3110         register char *up;
3111         register char *down;
3112         register I32 tmp;
3113         dTARGET;
3114         STRLEN len;
3115
3116         if (SP - MARK > 1)
3117             do_join(TARG, &PL_sv_no, MARK, SP);
3118         else
3119             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3120         up = SvPV_force(TARG, len);
3121         if (len > 1) {
3122             if (IN_UTF8) {      /* first reverse each character */
3123                 U8* s = (U8*)SvPVX(TARG);
3124                 U8* send = (U8*)(s + len);
3125                 while (s < send) {
3126                     if (*s < 0x80) {
3127                         s++;
3128                         continue;
3129                     }
3130                     else {
3131                         up = (char*)s;
3132                         s += UTF8SKIP(s);
3133                         down = (char*)(s - 1);
3134                         if (s > send || !((*down & 0xc0) == 0x80)) {
3135                             warn("Malformed UTF-8 character");
3136                             break;
3137                         }
3138                         while (down > up) {
3139                             tmp = *up;
3140                             *up++ = *down;
3141                             *down-- = tmp;
3142                         }
3143                     }
3144                 }
3145                 up = SvPVX(TARG);
3146             }
3147             down = SvPVX(TARG) + len - 1;
3148             while (down > up) {
3149                 tmp = *up;
3150                 *up++ = *down;
3151                 *down-- = tmp;
3152             }
3153             (void)SvPOK_only(TARG);
3154         }
3155         SP = MARK + 1;
3156         SETTARG;
3157     }
3158     RETURN;
3159 }
3160
3161 STATIC SV      *
3162 mul128(SV *sv, U8 m)
3163 {
3164   STRLEN          len;
3165   char           *s = SvPV(sv, len);
3166   char           *t;
3167   U32             i = 0;
3168
3169   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3170     SV             *tmpNew = newSVpv("0000000000", 10);
3171
3172     sv_catsv(tmpNew, sv);
3173     SvREFCNT_dec(sv);           /* free old sv */
3174     sv = tmpNew;
3175     s = SvPV(sv, len);
3176   }
3177   t = s + len - 1;
3178   while (!*t)                   /* trailing '\0'? */
3179     t--;
3180   while (t > s) {
3181     i = ((*t - '0') << 7) + m;
3182     *(t--) = '0' + (i % 10);
3183     m = i / 10;
3184   }
3185   return (sv);
3186 }
3187
3188 /* Explosives and implosives. */
3189
3190 #if 'I' == 73 && 'J' == 74
3191 /* On an ASCII/ISO kind of system */
3192 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3193 #else
3194 /*
3195   Some other sort of character set - use memchr() so we don't match
3196   the null byte.
3197  */
3198 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3199 #endif
3200
3201 PP(pp_unpack)
3202 {
3203     djSP;
3204     dPOPPOPssrl;
3205     SV **oldsp = SP;
3206     I32 gimme = GIMME_V;
3207     SV *sv;
3208     STRLEN llen;
3209     STRLEN rlen;
3210     register char *pat = SvPV(left, llen);
3211     register char *s = SvPV(right, rlen);
3212     char *strend = s + rlen;
3213     char *strbeg = s;
3214     register char *patend = pat + llen;
3215     I32 datumtype;
3216     register I32 len;
3217     register I32 bits;
3218
3219     /* These must not be in registers: */
3220     I16 ashort;
3221     int aint;
3222     I32 along;
3223 #ifdef HAS_QUAD
3224     Quad_t aquad;
3225 #endif
3226     U16 aushort;
3227     unsigned int auint;
3228     U32 aulong;
3229 #ifdef HAS_QUAD
3230     Uquad_t auquad;
3231 #endif
3232     char *aptr;
3233     float afloat;
3234     double adouble;
3235     I32 checksum = 0;
3236     register U32 culong;
3237     double cdouble;
3238     int commas = 0;
3239
3240     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3241         /*SUPPRESS 530*/
3242         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3243         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3244             patend++;
3245             while (isDIGIT(*patend) || *patend == '*')
3246                 patend++;
3247         }
3248         else
3249             patend++;
3250     }
3251     while (pat < patend) {
3252       reparse:
3253         datumtype = *pat++ & 0xFF;
3254         if (isSPACE(datumtype))
3255             continue;
3256         if (pat >= patend)
3257             len = 1;
3258         else if (*pat == '*') {
3259             len = strend - strbeg;      /* long enough */
3260             pat++;
3261         }
3262         else if (isDIGIT(*pat)) {
3263             len = *pat++ - '0';
3264             while (isDIGIT(*pat))
3265                 len = (len * 10) + (*pat++ - '0');
3266         }
3267         else
3268             len = (datumtype != '@');
3269         switch(datumtype) {
3270         default:
3271             croak("Invalid type in unpack: '%c'", (int)datumtype);
3272         case ',': /* grandfather in commas but with a warning */
3273             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3274                 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3275             break;
3276         case '%':
3277             if (len == 1 && pat[-1] != '1')
3278                 len = 16;
3279             checksum = len;
3280             culong = 0;
3281             cdouble = 0;
3282             if (pat < patend)
3283                 goto reparse;
3284             break;
3285         case '@':
3286             if (len > strend - strbeg)
3287                 DIE("@ outside of string");
3288             s = strbeg + len;
3289             break;
3290         case 'X':
3291             if (len > s - strbeg)
3292                 DIE("X outside of string");
3293             s -= len;
3294             break;
3295         case 'x':
3296             if (len > strend - s)
3297                 DIE("x outside of string");
3298             s += len;
3299             break;
3300         case 'A':
3301         case 'Z':
3302         case 'a':
3303             if (len > strend - s)
3304                 len = strend - s;
3305             if (checksum)
3306                 goto uchar_checksum;
3307             sv = NEWSV(35, len);
3308             sv_setpvn(sv, s, len);
3309             s += len;
3310             if (datumtype == 'A' || datumtype == 'Z') {
3311                 aptr = s;       /* borrow register */
3312                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3313                     s = SvPVX(sv);
3314                     while (*s)
3315                         s++;
3316                 }
3317                 else {          /* 'A' strips both nulls and spaces */
3318                     s = SvPVX(sv) + len - 1;
3319                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3320                         s--;
3321                     *++s = '\0';
3322                 }
3323                 SvCUR_set(sv, s - SvPVX(sv));
3324                 s = aptr;       /* unborrow register */
3325             }
3326             XPUSHs(sv_2mortal(sv));
3327             break;
3328         case 'B':
3329         case 'b':
3330             if (pat[-1] == '*' || len > (strend - s) * 8)
3331                 len = (strend - s) * 8;
3332             if (checksum) {
3333                 if (!PL_bitcount) {
3334                     Newz(601, PL_bitcount, 256, char);
3335                     for (bits = 1; bits < 256; bits++) {
3336                         if (bits & 1)   PL_bitcount[bits]++;
3337                         if (bits & 2)   PL_bitcount[bits]++;
3338                         if (bits & 4)   PL_bitcount[bits]++;
3339                         if (bits & 8)   PL_bitcount[bits]++;
3340                         if (bits & 16)  PL_bitcount[bits]++;
3341                         if (bits & 32)  PL_bitcount[bits]++;
3342                         if (bits & 64)  PL_bitcount[bits]++;
3343                         if (bits & 128) PL_bitcount[bits]++;
3344                     }
3345                 }
3346                 while (len >= 8) {
3347                     culong += PL_bitcount[*(unsigned char*)s++];
3348                     len -= 8;
3349                 }
3350                 if (len) {
3351                     bits = *s;
3352                     if (datumtype == 'b') {
3353                         while (len-- > 0) {
3354                             if (bits & 1) culong++;
3355                             bits >>= 1;
3356                         }
3357                     }
3358                     else {
3359                         while (len-- > 0) {
3360                             if (bits & 128) culong++;
3361                             bits <<= 1;
3362                         }
3363                     }
3364                 }
3365                 break;
3366             }
3367             sv = NEWSV(35, len + 1);
3368             SvCUR_set(sv, len);
3369             SvPOK_on(sv);
3370             aptr = pat;                 /* borrow register */
3371             pat = SvPVX(sv);
3372             if (datumtype == 'b') {
3373                 aint = len;
3374                 for (len = 0; len < aint; len++) {
3375                     if (len & 7)                /*SUPPRESS 595*/
3376                         bits >>= 1;
3377                     else
3378                         bits = *s++;
3379                     *pat++ = '0' + (bits & 1);
3380                 }
3381             }
3382             else {
3383                 aint = len;
3384                 for (len = 0; len < aint; len++) {
3385                     if (len & 7)
3386                         bits <<= 1;
3387                     else
3388                         bits = *s++;
3389                     *pat++ = '0' + ((bits & 128) != 0);
3390                 }
3391             }
3392             *pat = '\0';
3393             pat = aptr;                 /* unborrow register */
3394             XPUSHs(sv_2mortal(sv));
3395             break;
3396         case 'H':
3397         case 'h':
3398             if (pat[-1] == '*' || len > (strend - s) * 2)
3399                 len = (strend - s) * 2;
3400             sv = NEWSV(35, len + 1);
3401             SvCUR_set(sv, len);
3402             SvPOK_on(sv);
3403             aptr = pat;                 /* borrow register */
3404             pat = SvPVX(sv);
3405             if (datumtype == 'h') {
3406                 aint = len;
3407                 for (len = 0; len < aint; len++) {
3408                     if (len & 1)
3409                         bits >>= 4;
3410                     else
3411                         bits = *s++;
3412                     *pat++ = PL_hexdigit[bits & 15];
3413                 }
3414             }
3415             else {
3416                 aint = len;
3417                 for (len = 0; len < aint; len++) {
3418                     if (len & 1)
3419                         bits <<= 4;
3420                     else
3421                         bits = *s++;
3422                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3423                 }
3424             }
3425             *pat = '\0';
3426             pat = aptr;                 /* unborrow register */
3427             XPUSHs(sv_2mortal(sv));
3428             break;
3429         case 'c':
3430             if (len > strend - s)
3431                 len = strend - s;
3432             if (checksum) {
3433                 while (len-- > 0) {
3434                     aint = *s++;
3435                     if (aint >= 128)    /* fake up signed chars */
3436                         aint -= 256;
3437                     culong += aint;
3438                 }
3439             }
3440             else {
3441                 EXTEND(SP, len);
3442                 EXTEND_MORTAL(len);
3443                 while (len-- > 0) {
3444                     aint = *s++;
3445                     if (aint >= 128)    /* fake up signed chars */
3446                         aint -= 256;
3447                     sv = NEWSV(36, 0);
3448                     sv_setiv(sv, (IV)aint);
3449                     PUSHs(sv_2mortal(sv));
3450                 }
3451             }
3452             break;
3453         case 'C':
3454             if (len > strend - s)
3455                 len = strend - s;
3456             if (checksum) {
3457               uchar_checksum:
3458                 while (len-- > 0) {
3459                     auint = *s++ & 255;
3460                     culong += auint;
3461                 }
3462             }
3463             else {
3464                 EXTEND(SP, len);
3465                 EXTEND_MORTAL(len);
3466                 while (len-- > 0) {
3467                     auint = *s++ & 255;
3468                     sv = NEWSV(37, 0);
3469                     sv_setiv(sv, (IV)auint);
3470                     PUSHs(sv_2mortal(sv));
3471                 }
3472             }
3473             break;
3474         case 'U':
3475             if (len > strend - s)
3476                 len = strend - s;
3477             if (checksum) {
3478                 while (len-- > 0 && s < strend) {
3479                     auint = utf8_to_uv((U8*)s, &along);
3480                     s += along;
3481                     if (checksum > 32)
3482                         cdouble += (double)auint;
3483                     else
3484                         culong += auint;
3485                 }
3486             }
3487             else {
3488                 EXTEND(SP, len);
3489                 EXTEND_MORTAL(len);
3490                 while (len-- > 0 && s < strend) {
3491                     auint = utf8_to_uv((U8*)s, &along);
3492                     s += along;
3493                     sv = NEWSV(37, 0);
3494                     sv_setuv(sv, (UV)auint);
3495                     PUSHs(sv_2mortal(sv));
3496                 }
3497             }
3498             break;
3499         case 's':
3500             along = (strend - s) / SIZE16;
3501             if (len > along)
3502                 len = along;
3503             if (checksum) {
3504                 while (len-- > 0) {
3505                     COPY16(s, &ashort);
3506                     s += SIZE16;
3507                     culong += ashort;
3508                 }
3509             }
3510             else {
3511                 EXTEND(SP, len);
3512                 EXTEND_MORTAL(len);
3513                 while (len-- > 0) {
3514                     COPY16(s, &ashort);
3515                     s += SIZE16;
3516                     sv = NEWSV(38, 0);
3517                     sv_setiv(sv, (IV)ashort);
3518                     PUSHs(sv_2mortal(sv));
3519                 }
3520             }
3521             break;
3522         case 'v':
3523         case 'n':
3524         case 'S':
3525             along = (strend - s) / SIZE16;
3526             if (len > along)
3527                 len = along;
3528             if (checksum) {
3529                 while (len-- > 0) {
3530                     COPY16(s, &aushort);
3531                     s += SIZE16;
3532 #ifdef HAS_NTOHS
3533                     if (datumtype == 'n')
3534                         aushort = PerlSock_ntohs(aushort);
3535 #endif
3536 #ifdef HAS_VTOHS
3537                     if (datumtype == 'v')
3538                         aushort = vtohs(aushort);
3539 #endif
3540                     culong += aushort;
3541                 }
3542             }
3543             else {
3544                 EXTEND(SP, len);
3545                 EXTEND_MORTAL(len);
3546                 while (len-- > 0) {
3547                     COPY16(s, &aushort);
3548                     s += SIZE16;
3549                     sv = NEWSV(39, 0);
3550 #ifdef HAS_NTOHS
3551                     if (datumtype == 'n')
3552                         aushort = PerlSock_ntohs(aushort);
3553 #endif
3554 #ifdef HAS_VTOHS
3555                     if (datumtype == 'v')
3556                         aushort = vtohs(aushort);
3557 #endif
3558                     sv_setiv(sv, (IV)aushort);
3559                     PUSHs(sv_2mortal(sv));
3560                 }
3561             }
3562             break;
3563         case 'i':
3564             along = (strend - s) / sizeof(int);
3565             if (len > along)
3566                 len = along;
3567             if (checksum) {
3568                 while (len-- > 0) {
3569                     Copy(s, &aint, 1, int);
3570                     s += sizeof(int);
3571                     if (checksum > 32)
3572                         cdouble += (double)aint;
3573                     else
3574                         culong += aint;
3575                 }
3576             }
3577             else {
3578                 EXTEND(SP, len);
3579                 EXTEND_MORTAL(len);
3580                 while (len-- > 0) {
3581                     Copy(s, &aint, 1, int);
3582                     s += sizeof(int);
3583                     sv = NEWSV(40, 0);
3584 #ifdef __osf__
3585                     /* Without the dummy below unpack("i", pack("i",-1))
3586                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3587                      * cc with optimization turned on */
3588                     (aint) ?
3589                         sv_setiv(sv, (IV)aint) :
3590 #endif
3591                     sv_setiv(sv, (IV)aint);
3592                     PUSHs(sv_2mortal(sv));
3593                 }
3594             }
3595             break;
3596         case 'I':
3597             along = (strend - s) / sizeof(unsigned int);
3598             if (len > along)
3599                 len = along;
3600             if (checksum) {
3601                 while (len-- > 0) {
3602                     Copy(s, &auint, 1, unsigned int);
3603                     s += sizeof(unsigned int);
3604                     if (checksum > 32)
3605                         cdouble += (double)auint;
3606                     else
3607                         culong += auint;
3608                 }
3609             }
3610             else {
3611                 EXTEND(SP, len);
3612                 EXTEND_MORTAL(len);
3613                 while (len-- > 0) {
3614                     Copy(s, &auint, 1, unsigned int);
3615                     s += sizeof(unsigned int);
3616                     sv = NEWSV(41, 0);
3617 #ifdef __osf__
3618                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3619                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3620                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3621                      * with optimization turned on.
3622                      * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3623                      * does not have this problem even with -O4)
3624                      */
3625                     (auint) ?
3626                         sv_setuv(sv, (UV)auint) :
3627 #endif
3628                     sv_setuv(sv, (UV)auint);
3629                     PUSHs(sv_2mortal(sv));
3630                 }
3631             }
3632             break;
3633         case 'l':
3634             along = (strend - s) / SIZE32;
3635             if (len > along)
3636                 len = along;
3637             if (checksum) {
3638                 while (len-- > 0) {
3639                     COPY32(s, &along);
3640                     s += SIZE32;
3641                     if (checksum > 32)
3642                         cdouble += (double)along;
3643                     else
3644                         culong += along;
3645                 }
3646             }
3647             else {
3648                 EXTEND(SP, len);
3649                 EXTEND_MORTAL(len);
3650                 while (len-- > 0) {
3651                     COPY32(s, &along);
3652                     s += SIZE32;
3653                     sv = NEWSV(42, 0);
3654                     sv_setiv(sv, (IV)along);
3655                     PUSHs(sv_2mortal(sv));
3656                 }
3657             }
3658             break;
3659         case 'V':
3660         case 'N':
3661         case 'L':
3662             along = (strend - s) / SIZE32;
3663             if (len > along)
3664                 len = along;
3665             if (checksum) {
3666                 while (len-- > 0) {
3667                     COPY32(s, &aulong);
3668                     s += SIZE32;
3669 #ifdef HAS_NTOHL
3670                     if (datumtype == 'N')
3671                         aulong = PerlSock_ntohl(aulong);
3672 #endif
3673 #ifdef HAS_VTOHL
3674                     if (datumtype == 'V')
3675                         aulong = vtohl(aulong);
3676 #endif
3677                     if (checksum > 32)
3678                         cdouble += (double)aulong;
3679                     else
3680                         culong += aulong;
3681                 }
3682             }
3683             else {
3684                 EXTEND(SP, len);
3685                 EXTEND_MORTAL(len);
3686                 while (len-- > 0) {
3687                     COPY32(s, &aulong);
3688                     s += SIZE32;
3689 #ifdef HAS_NTOHL
3690                     if (datumtype == 'N')
3691                         aulong = PerlSock_ntohl(aulong);
3692 #endif
3693 #ifdef HAS_VTOHL
3694                     if (datumtype == 'V')
3695                         aulong = vtohl(aulong);
3696 #endif
3697                     sv = NEWSV(43, 0);
3698                     sv_setuv(sv, (UV)aulong);
3699                     PUSHs(sv_2mortal(sv));
3700                 }
3701             }
3702             break;
3703         case 'p':
3704             along = (strend - s) / sizeof(char*);
3705             if (len > along)
3706                 len = along;
3707             EXTEND(SP, len);
3708             EXTEND_MORTAL(len);
3709             while (len-- > 0) {
3710                 if (sizeof(char*) > strend - s)
3711                     break;
3712                 else {
3713                     Copy(s, &aptr, 1, char*);
3714                     s += sizeof(char*);
3715                 }
3716                 sv = NEWSV(44, 0);
3717                 if (aptr)
3718                     sv_setpv(sv, aptr);
3719                 PUSHs(sv_2mortal(sv));
3720             }
3721             break;
3722         case 'w':
3723             EXTEND(SP, len);
3724             EXTEND_MORTAL(len);
3725             {
3726                 UV auv = 0;
3727                 U32 bytes = 0;
3728
3729                 while ((len > 0) && (s < strend)) {
3730                     auv = (auv << 7) | (*s & 0x7f);
3731                     if (!(*s++ & 0x80)) {
3732                         bytes = 0;
3733                         sv = NEWSV(40, 0);
3734                         sv_setuv(sv, auv);
3735                         PUSHs(sv_2mortal(sv));
3736                         len--;
3737                         auv = 0;
3738                     }
3739                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3740                         char *t;
3741                         STRLEN n_a;
3742
3743                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3744                         while (s < strend) {
3745                             sv = mul128(sv, *s & 0x7f);
3746                             if (!(*s++ & 0x80)) {
3747                                 bytes = 0;
3748                                 break;
3749                             }
3750                         }
3751                         t = SvPV(sv, n_a);
3752                         while (*t == '0')
3753                             t++;
3754                         sv_chop(sv, t);
3755                         PUSHs(sv_2mortal(sv));
3756                         len--;
3757                         auv = 0;
3758                     }
3759                 }
3760                 if ((s >= strend) && bytes)
3761                     croak("Unterminated compressed integer");
3762             }
3763             break;
3764         case 'P':
3765             EXTEND(SP, 1);
3766             if (sizeof(char*) > strend - s)
3767                 break;
3768             else {
3769                 Copy(s, &aptr, 1, char*);
3770                 s += sizeof(char*);
3771             }
3772             sv = NEWSV(44, 0);
3773             if (aptr)
3774                 sv_setpvn(sv, aptr, len);
3775             PUSHs(sv_2mortal(sv));
3776             break;
3777 #ifdef HAS_QUAD
3778         case 'q':
3779             along = (strend - s) / sizeof(Quad_t);
3780             if (len > along)
3781                 len = along;
3782             EXTEND(SP, len);
3783             EXTEND_MORTAL(len);
3784             while (len-- > 0) {
3785                 if (s + sizeof(Quad_t) > strend)
3786                     aquad = 0;
3787                 else {
3788                     Copy(s, &aquad, 1, Quad_t);
3789                     s += sizeof(Quad_t);
3790                 }
3791                 sv = NEWSV(42, 0);
3792                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3793                     sv_setiv(sv, (IV)aquad);
3794                 else
3795                     sv_setnv(sv, (double)aquad);
3796                 PUSHs(sv_2mortal(sv));
3797             }
3798             break;
3799         case 'Q':
3800             along = (strend - s) / sizeof(Quad_t);
3801             if (len > along)
3802                 len = along;
3803             EXTEND(SP, len);
3804             EXTEND_MORTAL(len);
3805             while (len-- > 0) {
3806                 if (s + sizeof(Uquad_t) > strend)
3807                     auquad = 0;
3808                 else {
3809                     Copy(s, &auquad, 1, Uquad_t);
3810                     s += sizeof(Uquad_t);
3811                 }
3812                 sv = NEWSV(43, 0);
3813                 if (auquad <= UV_MAX)
3814                     sv_setuv(sv, (UV)auquad);
3815                 else
3816                     sv_setnv(sv, (double)auquad);
3817                 PUSHs(sv_2mortal(sv));
3818             }
3819             break;
3820 #endif
3821         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3822         case 'f':
3823         case 'F':
3824             along = (strend - s) / sizeof(float);
3825             if (len > along)
3826                 len = along;
3827             if (checksum) {
3828                 while (len-- > 0) {
3829                     Copy(s, &afloat, 1, float);
3830                     s += sizeof(float);
3831                     cdouble += afloat;
3832                 }
3833             }
3834             else {
3835                 EXTEND(SP, len);
3836                 EXTEND_MORTAL(len);
3837                 while (len-- > 0) {
3838                     Copy(s, &afloat, 1, float);
3839                     s += sizeof(float);
3840                     sv = NEWSV(47, 0);
3841                     sv_setnv(sv, (double)afloat);
3842                     PUSHs(sv_2mortal(sv));
3843                 }
3844             }
3845             break;
3846         case 'd':
3847         case 'D':
3848             along = (strend - s) / sizeof(double);
3849             if (len > along)
3850                 len = along;
3851             if (checksum) {
3852                 while (len-- > 0) {
3853                     Copy(s, &adouble, 1, double);
3854                     s += sizeof(double);
3855                     cdouble += adouble;
3856                 }
3857             }
3858             else {
3859                 EXTEND(SP, len);
3860                 EXTEND_MORTAL(len);
3861                 while (len-- > 0) {
3862                     Copy(s, &adouble, 1, double);
3863                     s += sizeof(double);
3864                     sv = NEWSV(48, 0);
3865                     sv_setnv(sv, (double)adouble);
3866                     PUSHs(sv_2mortal(sv));
3867                 }
3868             }
3869             break;
3870         case 'u':
3871             /* MKS:
3872              * Initialise the decode mapping.  By using a table driven
3873              * algorithm, the code will be character-set independent
3874              * (and just as fast as doing character arithmetic)
3875              */
3876             if (PL_uudmap['M'] == 0) {
3877                 int i;
3878
3879                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
3880                     PL_uudmap[PL_uuemap[i]] = i;
3881                 /*
3882                  * Because ' ' and '`' map to the same value,
3883                  * we need to decode them both the same.
3884                  */
3885                 PL_uudmap[' '] = 0;
3886             }
3887
3888             along = (strend - s) * 3 / 4;
3889             sv = NEWSV(42, along);
3890             if (along)
3891                 SvPOK_on(sv);
3892             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3893                 I32 a, b, c, d;
3894                 char hunk[4];
3895
3896                 hunk[3] = '\0';
3897                 len = PL_uudmap[*s++] & 077;
3898                 while (len > 0) {
3899                     if (s < strend && ISUUCHAR(*s))
3900                         a = PL_uudmap[*s++] & 077;
3901                     else
3902                         a = 0;
3903                     if (s < strend && ISUUCHAR(*s))
3904                         b = PL_uudmap[*s++] & 077;
3905                     else
3906                         b = 0;
3907                     if (s < strend && ISUUCHAR(*s))
3908                         c = PL_uudmap[*s++] & 077;
3909                     else
3910                         c = 0;
3911                     if (s < strend && ISUUCHAR(*s))
3912                         d = PL_uudmap[*s++] & 077;
3913                     else
3914                         d = 0;
3915                     hunk[0] = (a << 2) | (b >> 4);
3916                     hunk[1] = (b << 4) | (c >> 2);
3917                     hunk[2] = (c << 6) | d;
3918                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3919                     len -= 3;
3920                 }
3921                 if (*s == '\n')
3922                     s++;
3923                 else if (s[1] == '\n')          /* possible checksum byte */
3924                     s += 2;
3925             }
3926             XPUSHs(sv_2mortal(sv));
3927             break;
3928         }
3929         if (checksum) {
3930             sv = NEWSV(42, 0);
3931             if (strchr("fFdD", datumtype) ||
3932               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3933                 double trouble;
3934
3935                 adouble = 1.0;
3936                 while (checksum >= 16) {
3937                     checksum -= 16;
3938                     adouble *= 65536.0;
3939                 }
3940                 while (checksum >= 4) {
3941                     checksum -= 4;
3942                     adouble *= 16.0;
3943                 }
3944                 while (checksum--)
3945                     adouble *= 2.0;
3946                 along = (1 << checksum) - 1;
3947                 while (cdouble < 0.0)
3948                     cdouble += adouble;
3949                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3950                 sv_setnv(sv, cdouble);
3951             }
3952             else {
3953                 if (checksum < 32) {
3954                     aulong = (1 << checksum) - 1;
3955                     culong &= aulong;
3956                 }
3957                 sv_setuv(sv, (UV)culong);
3958             }
3959             XPUSHs(sv_2mortal(sv));
3960             checksum = 0;
3961         }
3962     }
3963     if (SP == oldsp && gimme == G_SCALAR)
3964         PUSHs(&PL_sv_undef);
3965     RETURN;
3966 }
3967
3968 STATIC void
3969 doencodes(register SV *sv, register char *s, register I32 len)
3970 {
3971     char hunk[5];
3972
3973     *hunk = PL_uuemap[len];
3974     sv_catpvn(sv, hunk, 1);
3975     hunk[4] = '\0';
3976     while (len > 2) {
3977         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
3978         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3979         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3980         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
3981         sv_catpvn(sv, hunk, 4);
3982         s += 3;
3983         len -= 3;
3984     }
3985     if (len > 0) {
3986         char r = (len > 1 ? s[1] : '\0');
3987         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
3988         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3989         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
3990         hunk[3] = PL_uuemap[0];
3991         sv_catpvn(sv, hunk, 4);
3992     }
3993     sv_catpvn(sv, "\n", 1);
3994 }
3995
3996 STATIC SV      *
3997 is_an_int(char *s, STRLEN l)
3998 {
3999   STRLEN         n_a;
4000   SV             *result = newSVpv("", l);
4001   char           *result_c = SvPV(result, n_a); /* convenience */
4002   char           *out = result_c;
4003   bool            skip = 1;
4004   bool            ignore = 0;
4005
4006   while (*s) {
4007     switch (*s) {
4008     case ' ':
4009       break;
4010     case '+':
4011       if (!skip) {
4012         SvREFCNT_dec(result);
4013         return (NULL);
4014       }
4015       break;
4016     case '0':
4017     case '1':
4018     case '2':
4019     case '3':
4020     case '4':
4021     case '5':
4022     case '6':
4023     case '7':
4024     case '8':
4025     case '9':
4026       skip = 0;
4027       if (!ignore) {
4028         *(out++) = *s;
4029       }
4030       break;
4031     case '.':
4032       ignore = 1;
4033       break;
4034     default:
4035       SvREFCNT_dec(result);
4036       return (NULL);
4037     }
4038     s++;
4039   }
4040   *(out++) = '\0';
4041   SvCUR_set(result, out - result_c);
4042   return (result);
4043 }
4044
4045 STATIC int
4046 div128(SV *pnum, bool *done)
4047                                             /* must be '\0' terminated */
4048
4049 {
4050   STRLEN          len;
4051   char           *s = SvPV(pnum, len);
4052   int             m = 0;
4053   int             r = 0;
4054   char           *t = s;
4055
4056   *done = 1;
4057   while (*t) {
4058     int             i;
4059
4060     i = m * 10 + (*t - '0');
4061     m = i & 0x7F;
4062     r = (i >> 7);               /* r < 10 */
4063     if (r) {
4064       *done = 0;
4065     }
4066     *(t++) = '0' + r;
4067   }
4068   *(t++) = '\0';
4069   SvCUR_set(pnum, (STRLEN) (t - s));
4070   return (m);
4071 }
4072
4073
4074 PP(pp_pack)
4075 {
4076     djSP; dMARK; dORIGMARK; dTARGET;
4077     register SV *cat = TARG;
4078     register I32 items;
4079     STRLEN fromlen;
4080     register char *pat = SvPVx(*++MARK, fromlen);
4081     register char *patend = pat + fromlen;
4082     register I32 len;
4083     I32 datumtype;
4084     SV *fromstr;
4085     /*SUPPRESS 442*/
4086     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4087     static char *space10 = "          ";
4088
4089     /* These must not be in registers: */
4090     char achar;
4091     I16 ashort;
4092     int aint;
4093     unsigned int auint;
4094     I32 along;
4095     U32 aulong;
4096 #ifdef HAS_QUAD
4097     Quad_t aquad;
4098     Uquad_t auquad;
4099 #endif
4100     char *aptr;
4101     float afloat;
4102     double adouble;
4103     int commas = 0;
4104
4105     items = SP - MARK;
4106     MARK++;
4107     sv_setpvn(cat, "", 0);
4108     while (pat < patend) {
4109 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4110         datumtype = *pat++ & 0xFF;
4111         if (isSPACE(datumtype))
4112             continue;
4113         if (*pat == '*') {
4114             len = strchr("@Xxu", datumtype) ? 0 : items;
4115             pat++;
4116         }
4117         else if (isDIGIT(*pat)) {
4118             len = *pat++ - '0';
4119             while (isDIGIT(*pat))
4120                 len = (len * 10) + (*pat++ - '0');
4121         }
4122         else
4123             len = 1;
4124         switch(datumtype) {
4125         default:
4126             croak("Invalid type in pack: '%c'", (int)datumtype);
4127         case ',': /* grandfather in commas but with a warning */
4128             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4129                 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4130             break;
4131         case '%':
4132             DIE("%% may only be used in unpack");
4133         case '@':
4134             len -= SvCUR(cat);
4135             if (len > 0)
4136                 goto grow;
4137             len = -len;
4138             if (len > 0)
4139                 goto shrink;
4140             break;
4141         case 'X':
4142           shrink:
4143             if (SvCUR(cat) < len)
4144                 DIE("X outside of string");
4145             SvCUR(cat) -= len;
4146             *SvEND(cat) = '\0';
4147             break;
4148         case 'x':
4149           grow:
4150             while (len >= 10) {
4151                 sv_catpvn(cat, null10, 10);
4152                 len -= 10;
4153             }
4154             sv_catpvn(cat, null10, len);
4155             break;
4156         case 'A':
4157         case 'Z':
4158         case 'a':
4159             fromstr = NEXTFROM;
4160             aptr = SvPV(fromstr, fromlen);
4161             if (pat[-1] == '*')
4162                 len = fromlen;
4163             if (fromlen > len)
4164                 sv_catpvn(cat, aptr, len);
4165             else {
4166                 sv_catpvn(cat, aptr, fromlen);
4167                 len -= fromlen;
4168                 if (datumtype == 'A') {
4169                     while (len >= 10) {
4170                         sv_catpvn(cat, space10, 10);
4171                         len -= 10;
4172                     }
4173                     sv_catpvn(cat, space10, len);
4174                 }
4175                 else {
4176                     while (len >= 10) {
4177                         sv_catpvn(cat, null10, 10);
4178                         len -= 10;
4179                     }
4180                     sv_catpvn(cat, null10, len);
4181                 }
4182             }
4183             break;
4184         case 'B':
4185         case 'b':
4186             {
4187                 char *savepat = pat;
4188                 I32 saveitems;
4189
4190                 fromstr = NEXTFROM;
4191                 saveitems = items;
4192                 aptr = SvPV(fromstr, fromlen);
4193                 if (pat[-1] == '*')
4194                     len = fromlen;
4195                 pat = aptr;
4196                 aint = SvCUR(cat);
4197                 SvCUR(cat) += (len+7)/8;
4198                 SvGROW(cat, SvCUR(cat) + 1);
4199                 aptr = SvPVX(cat) + aint;
4200                 if (len > fromlen)
4201                     len = fromlen;
4202                 aint = len;
4203                 items = 0;
4204                 if (datumtype == 'B') {
4205                     for (len = 0; len++ < aint;) {
4206                         items |= *pat++ & 1;
4207                         if (len & 7)
4208                             items <<= 1;
4209                         else {
4210                             *aptr++ = items & 0xff;
4211                             items = 0;
4212                         }
4213                     }
4214                 }
4215                 else {
4216                     for (len = 0; len++ < aint;) {
4217                         if (*pat++ & 1)
4218                             items |= 128;
4219                         if (len & 7)
4220                             items >>= 1;
4221                         else {
4222                             *aptr++ = items & 0xff;
4223                             items = 0;
4224                         }
4225                     }
4226                 }
4227                 if (aint & 7) {
4228                     if (datumtype == 'B')
4229                         items <<= 7 - (aint & 7);
4230                     else
4231                         items >>= 7 - (aint & 7);
4232                     *aptr++ = items & 0xff;
4233                 }
4234                 pat = SvPVX(cat) + SvCUR(cat);
4235                 while (aptr <= pat)
4236                     *aptr++ = '\0';
4237
4238                 pat = savepat;
4239                 items = saveitems;
4240             }
4241             break;
4242         case 'H':
4243         case 'h':
4244             {
4245                 char *savepat = pat;
4246                 I32 saveitems;
4247
4248                 fromstr = NEXTFROM;
4249                 saveitems = items;
4250                 aptr = SvPV(fromstr, fromlen);
4251                 if (pat[-1] == '*')
4252                     len = fromlen;
4253                 pat = aptr;
4254                 aint = SvCUR(cat);
4255                 SvCUR(cat) += (len+1)/2;
4256                 SvGROW(cat, SvCUR(cat) + 1);
4257                 aptr = SvPVX(cat) + aint;
4258                 if (len > fromlen)
4259                     len = fromlen;
4260                 aint = len;
4261                 items = 0;
4262                 if (datumtype == 'H') {
4263                     for (len = 0; len++ < aint;) {
4264                         if (isALPHA(*pat))
4265                             items |= ((*pat++ & 15) + 9) & 15;
4266                         else
4267                             items |= *pat++ & 15;
4268                         if (len & 1)
4269                             items <<= 4;
4270                         else {
4271                             *aptr++ = items & 0xff;
4272                             items = 0;
4273                         }
4274                     }
4275                 }
4276                 else {
4277                     for (len = 0; len++ < aint;) {
4278                         if (isALPHA(*pat))
4279                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4280                         else
4281                             items |= (*pat++ & 15) << 4;
4282                         if (len & 1)
4283                             items >>= 4;
4284                         else {
4285                             *aptr++ = items & 0xff;
4286                             items = 0;
4287                         }
4288                     }
4289                 }
4290                 if (aint & 1)
4291                     *aptr++ = items & 0xff;
4292                 pat = SvPVX(cat) + SvCUR(cat);
4293                 while (aptr <= pat)
4294                     *aptr++ = '\0';
4295
4296                 pat = savepat;
4297                 items = saveitems;
4298             }
4299             break;
4300         case 'C':
4301         case 'c':
4302             while (len-- > 0) {
4303                 fromstr = NEXTFROM;
4304                 aint = SvIV(fromstr);
4305                 achar = aint;
4306                 sv_catpvn(cat, &achar, sizeof(char));
4307             }
4308             break;
4309         case 'U':
4310             while (len-- > 0) {
4311                 fromstr = NEXTFROM;
4312                 auint = SvUV(fromstr);
4313                 SvGROW(cat, SvCUR(cat) + 10);
4314                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4315                                - SvPVX(cat));
4316             }
4317             *SvEND(cat) = '\0';
4318             break;
4319         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4320         case 'f':
4321         case 'F':
4322             while (len-- > 0) {
4323                 fromstr = NEXTFROM;
4324                 afloat = (float)SvNV(fromstr);
4325                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4326             }
4327             break;
4328         case 'd':
4329         case 'D':
4330             while (len-- > 0) {
4331                 fromstr = NEXTFROM;
4332                 adouble = (double)SvNV(fromstr);
4333                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4334             }
4335             break;
4336         case 'n':
4337             while (len-- > 0) {
4338                 fromstr = NEXTFROM;
4339                 ashort = (I16)SvIV(fromstr);
4340 #ifdef HAS_HTONS
4341                 ashort = PerlSock_htons(ashort);
4342 #endif
4343                 CAT16(cat, &ashort);
4344             }
4345             break;
4346         case 'v':
4347             while (len-- > 0) {
4348                 fromstr = NEXTFROM;
4349                 ashort = (I16)SvIV(fromstr);
4350 #ifdef HAS_HTOVS
4351                 ashort = htovs(ashort);
4352 #endif
4353                 CAT16(cat, &ashort);
4354             }
4355             break;
4356         case 'S':
4357         case 's':
4358             while (len-- > 0) {
4359                 fromstr = NEXTFROM;
4360                 ashort = (I16)SvIV(fromstr);
4361                 CAT16(cat, &ashort);
4362             }
4363             break;
4364         case 'I':
4365             while (len-- > 0) {
4366                 fromstr = NEXTFROM;
4367                 auint = SvUV(fromstr);
4368                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4369             }
4370             break;
4371         case 'w':
4372             while (len-- > 0) {
4373                 fromstr = NEXTFROM;
4374                 adouble = floor(SvNV(fromstr));
4375
4376                 if (adouble < 0)
4377                     croak("Cannot compress negative numbers");
4378
4379                 if (
4380 #ifdef BW_BITS
4381                     adouble <= BW_MASK
4382 #else
4383 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4384                     adouble <= UV_MAX_cxux
4385 #else
4386                     adouble <= UV_MAX
4387 #endif
4388 #endif
4389                     )
4390                 {
4391                     char   buf[1 + sizeof(UV)];
4392                     char  *in = buf + sizeof(buf);
4393                     UV     auv = U_V(adouble);;
4394
4395                     do {
4396                         *--in = (auv & 0x7f) | 0x80;
4397                         auv >>= 7;
4398                     } while (auv);
4399                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4400                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4401                 }
4402                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4403                     char           *from, *result, *in;
4404                     SV             *norm;
4405                     STRLEN          len;
4406                     bool            done;
4407
4408                     /* Copy string and check for compliance */
4409                     from = SvPV(fromstr, len);
4410                     if ((norm = is_an_int(from, len)) == NULL)
4411                         croak("can compress only unsigned integer");
4412
4413                     New('w', result, len, char);
4414                     in = result + len;
4415                     done = FALSE;
4416                     while (!done)
4417                         *--in = div128(norm, &done) | 0x80;
4418                     result[len - 1] &= 0x7F; /* clear continue bit */
4419                     sv_catpvn(cat, in, (result + len) - in);
4420                     Safefree(result);
4421                     SvREFCNT_dec(norm); /* free norm */
4422                 }
4423                 else if (SvNOKp(fromstr)) {
4424                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4425                     char  *in = buf + sizeof(buf);
4426
4427                     do {
4428                         double next = floor(adouble / 128);
4429                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4430                         if (--in < buf)  /* this cannot happen ;-) */
4431                             croak ("Cannot compress integer");
4432                         adouble = next;
4433                     } while (adouble > 0);
4434                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4435                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4436                 }
4437                 else
4438                     croak("Cannot compress non integer");
4439             }
4440             break;
4441         case 'i':
4442             while (len-- > 0) {
4443                 fromstr = NEXTFROM;
4444                 aint = SvIV(fromstr);
4445                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4446             }
4447             break;
4448         case 'N':
4449             while (len-- > 0) {
4450                 fromstr = NEXTFROM;
4451                 aulong = SvUV(fromstr);
4452 #ifdef HAS_HTONL
4453                 aulong = PerlSock_htonl(aulong);
4454 #endif
4455                 CAT32(cat, &aulong);
4456             }
4457             break;
4458         case 'V':
4459             while (len-- > 0) {
4460                 fromstr = NEXTFROM;
4461                 aulong = SvUV(fromstr);
4462 #ifdef HAS_HTOVL
4463                 aulong = htovl(aulong);
4464 #endif
4465                 CAT32(cat, &aulong);
4466             }
4467             break;
4468         case 'L':
4469             while (len-- > 0) {
4470                 fromstr = NEXTFROM;
4471                 aulong = SvUV(fromstr);
4472                 CAT32(cat, &aulong);
4473             }
4474             break;
4475         case 'l':
4476             while (len-- > 0) {
4477                 fromstr = NEXTFROM;
4478                 along = SvIV(fromstr);
4479                 CAT32(cat, &along);
4480             }
4481             break;
4482 #ifdef HAS_QUAD
4483         case 'Q':
4484             while (len-- > 0) {
4485                 fromstr = NEXTFROM;
4486                 auquad = (Uquad_t)SvIV(fromstr);
4487                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4488             }
4489             break;
4490         case 'q':
4491             while (len-- > 0) {
4492                 fromstr = NEXTFROM;
4493                 aquad = (Quad_t)SvIV(fromstr);
4494                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4495             }
4496             break;
4497 #endif /* HAS_QUAD */
4498         case 'P':
4499             len = 1;            /* assume SV is correct length */
4500             /* FALL THROUGH */
4501         case 'p':
4502             while (len-- > 0) {
4503                 fromstr = NEXTFROM;
4504                 if (fromstr == &PL_sv_undef)
4505                     aptr = NULL;
4506                 else {
4507                     STRLEN n_a;
4508                     /* XXX better yet, could spirit away the string to
4509                      * a safe spot and hang on to it until the result
4510                      * of pack() (and all copies of the result) are
4511                      * gone.
4512                      */
4513                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4514                         warner(WARN_UNSAFE,
4515                                 "Attempt to pack pointer to temporary value");
4516                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4517                         aptr = SvPV(fromstr,n_a);
4518                     else
4519                         aptr = SvPV_force(fromstr,n_a);
4520                 }
4521                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4522             }
4523             break;
4524         case 'u':
4525             fromstr = NEXTFROM;
4526             aptr = SvPV(fromstr, fromlen);
4527             SvGROW(cat, fromlen * 4 / 3);
4528             if (len <= 1)
4529                 len = 45;
4530             else
4531                 len = len / 3 * 3;
4532             while (fromlen > 0) {
4533                 I32 todo;
4534
4535                 if (fromlen > len)
4536                     todo = len;
4537                 else
4538                     todo = fromlen;
4539                 doencodes(cat, aptr, todo);
4540                 fromlen -= todo;
4541                 aptr += todo;
4542             }
4543             break;
4544         }
4545     }
4546     SvSETMAGIC(cat);
4547     SP = ORIGMARK;
4548     PUSHs(cat);
4549     RETURN;
4550 }
4551 #undef NEXTFROM
4552
4553
4554 PP(pp_split)
4555 {
4556     djSP; dTARG;
4557     AV *ary;
4558     register I32 limit = POPi;                  /* note, negative is forever */
4559     SV *sv = POPs;
4560     STRLEN len;
4561     register char *s = SvPV(sv, len);
4562     char *strend = s + len;
4563     register PMOP *pm;
4564     register REGEXP *rx;
4565     register SV *dstr;
4566     register char *m;
4567     I32 iters = 0;
4568     I32 maxiters = (strend - s) + 10;
4569     I32 i;
4570     char *orig;
4571     I32 origlimit = limit;
4572     I32 realarray = 0;
4573     I32 base;
4574     AV *oldstack = PL_curstack;
4575     I32 gimme = GIMME_V;
4576     I32 oldsave = PL_savestack_ix;
4577     I32 make_mortal = 1;
4578     MAGIC *mg = (MAGIC *) NULL;
4579
4580 #ifdef DEBUGGING
4581     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4582 #else
4583     pm = (PMOP*)POPs;
4584 #endif
4585     if (!pm || !s)
4586         DIE("panic: do_split");
4587     rx = pm->op_pmregexp;
4588
4589     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4590              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4591
4592     if (pm->op_pmreplroot)
4593         ary = GvAVn((GV*)pm->op_pmreplroot);
4594     else if (gimme != G_ARRAY)
4595 #ifdef USE_THREADS
4596         ary = (AV*)PL_curpad[0];
4597 #else
4598         ary = GvAVn(PL_defgv);
4599 #endif /* USE_THREADS */
4600     else
4601         ary = Nullav;
4602     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4603         realarray = 1;
4604         PUTBACK;
4605         av_extend(ary,0);
4606         av_clear(ary);
4607         SPAGAIN;
4608         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4609             PUSHMARK(SP);
4610             XPUSHs(SvTIED_obj((SV*)ary, mg));
4611         }
4612         else {
4613             if (!AvREAL(ary)) {
4614                 AvREAL_on(ary);
4615                 for (i = AvFILLp(ary); i >= 0; i--)
4616                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4617             }
4618             /* temporarily switch stacks */
4619             SWITCHSTACK(PL_curstack, ary);
4620             make_mortal = 0;
4621         }
4622     }
4623     base = SP - PL_stack_base;
4624     orig = s;
4625     if (pm->op_pmflags & PMf_SKIPWHITE) {
4626         if (pm->op_pmflags & PMf_LOCALE) {
4627             while (isSPACE_LC(*s))
4628                 s++;
4629         }
4630         else {
4631             while (isSPACE(*s))
4632                 s++;
4633         }
4634     }
4635     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4636         SAVEINT(PL_multiline);
4637         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4638     }
4639
4640     if (!limit)
4641         limit = maxiters + 2;
4642     if (pm->op_pmflags & PMf_WHITE) {
4643         while (--limit) {
4644             m = s;
4645             while (m < strend &&
4646                    !((pm->op_pmflags & PMf_LOCALE)
4647                      ? isSPACE_LC(*m) : isSPACE(*m)))
4648                 ++m;
4649             if (m >= strend)
4650                 break;
4651
4652             dstr = NEWSV(30, m-s);
4653             sv_setpvn(dstr, s, m-s);
4654             if (make_mortal)
4655                 sv_2mortal(dstr);
4656             XPUSHs(dstr);
4657
4658             s = m + 1;
4659             while (s < strend &&
4660                    ((pm->op_pmflags & PMf_LOCALE)
4661                     ? isSPACE_LC(*s) : isSPACE(*s)))
4662                 ++s;
4663         }
4664     }
4665     else if (strEQ("^", rx->precomp)) {
4666         while (--limit) {
4667             /*SUPPRESS 530*/
4668             for (m = s; m < strend && *m != '\n'; m++) ;
4669             m++;
4670             if (m >= strend)
4671                 break;
4672             dstr = NEWSV(30, m-s);
4673             sv_setpvn(dstr, s, m-s);
4674             if (make_mortal)
4675                 sv_2mortal(dstr);
4676             XPUSHs(dstr);
4677             s = m;
4678         }
4679     }
4680     else if (rx->check_substr && !rx->nparens
4681              && (rx->reganch & ROPT_CHECK_ALL)
4682              && !(rx->reganch & ROPT_ANCH)) {
4683         i = SvCUR(rx->check_substr);
4684         if (i == 1 && !SvTAIL(rx->check_substr)) {
4685             i = *SvPVX(rx->check_substr);
4686             while (--limit) {
4687                 /*SUPPRESS 530*/
4688                 for (m = s; m < strend && *m != i; m++) ;
4689                 if (m >= strend)
4690                     break;
4691                 dstr = NEWSV(30, m-s);
4692                 sv_setpvn(dstr, s, m-s);
4693                 if (make_mortal)
4694                     sv_2mortal(dstr);
4695                 XPUSHs(dstr);
4696                 s = m + 1;
4697             }
4698         }
4699         else {
4700 #ifndef lint
4701             while (s < strend && --limit &&
4702               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4703                     rx->check_substr, 0)) )
4704 #endif
4705             {
4706                 dstr = NEWSV(31, m-s);
4707                 sv_setpvn(dstr, s, m-s);
4708                 if (make_mortal)
4709                     sv_2mortal(dstr);
4710                 XPUSHs(dstr);
4711                 s = m + i;
4712             }
4713         }
4714     }
4715     else {
4716         maxiters += (strend - s) * rx->nparens;
4717         while (s < strend && --limit &&
4718                CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4719         {
4720             TAINT_IF(RX_MATCH_TAINTED(rx));
4721             if (rx->subbase
4722               && rx->subbase != orig) {
4723                 m = s;
4724                 s = orig;
4725                 orig = rx->subbase;
4726                 s = orig + (m - s);
4727                 strend = s + (strend - m);
4728             }
4729             m = rx->startp[0];
4730             dstr = NEWSV(32, m-s);
4731             sv_setpvn(dstr, s, m-s);
4732             if (make_mortal)
4733                 sv_2mortal(dstr);
4734             XPUSHs(dstr);
4735             if (rx->nparens) {
4736                 for (i = 1; i <= rx->nparens; i++) {
4737                     s = rx->startp[i];
4738                     m = rx->endp[i];
4739                     if (m && s) {
4740                         dstr = NEWSV(33, m-s);
4741                         sv_setpvn(dstr, s, m-s);
4742                     }
4743                     else
4744                         dstr = NEWSV(33, 0);
4745                     if (make_mortal)
4746                         sv_2mortal(dstr);
4747                     XPUSHs(dstr);
4748                 }
4749             }
4750             s = rx->endp[0];
4751         }
4752     }
4753
4754     LEAVE_SCOPE(oldsave);
4755     iters = (SP - PL_stack_base) - base;
4756     if (iters > maxiters)
4757         DIE("Split loop");
4758
4759     /* keep field after final delim? */
4760     if (s < strend || (iters && origlimit)) {
4761         dstr = NEWSV(34, strend-s);
4762         sv_setpvn(dstr, s, strend-s);
4763         if (make_mortal)
4764             sv_2mortal(dstr);
4765         XPUSHs(dstr);
4766         iters++;
4767     }
4768     else if (!origlimit) {
4769         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4770             iters--, SP--;
4771     }
4772
4773     if (realarray) {
4774         if (!mg) {
4775             SWITCHSTACK(ary, oldstack);
4776             if (SvSMAGICAL(ary)) {
4777                 PUTBACK;
4778                 mg_set((SV*)ary);
4779                 SPAGAIN;
4780             }
4781             if (gimme == G_ARRAY) {
4782                 EXTEND(SP, iters);
4783                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4784                 SP += iters;
4785                 RETURN;
4786             }
4787         }
4788         else {
4789             PUTBACK;
4790             ENTER;
4791             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4792             LEAVE;
4793             SPAGAIN;
4794             if (gimme == G_ARRAY) {
4795                 /* EXTEND should not be needed - we just popped them */
4796                 EXTEND(SP, iters);
4797                 for (i=0; i < iters; i++) {
4798                     SV **svp = av_fetch(ary, i, FALSE);
4799                     PUSHs((svp) ? *svp : &PL_sv_undef);
4800                 }
4801                 RETURN;
4802             }
4803         }
4804     }
4805     else {
4806         if (gimme == G_ARRAY)
4807             RETURN;
4808     }
4809     if (iters || !pm->op_pmreplroot) {
4810         GETTARGET;
4811         PUSHi(iters);
4812         RETURN;
4813     }
4814     RETPUSHUNDEF;
4815 }
4816
4817 #ifdef USE_THREADS
4818 void
4819 unlock_condpair(void *svv)
4820 {
4821     dTHR;
4822     MAGIC *mg = mg_find((SV*)svv, 'm');
4823
4824     if (!mg)
4825         croak("panic: unlock_condpair unlocking non-mutex");
4826     MUTEX_LOCK(MgMUTEXP(mg));
4827     if (MgOWNER(mg) != thr)
4828         croak("panic: unlock_condpair unlocking mutex that we don't own");
4829     MgOWNER(mg) = 0;
4830     COND_SIGNAL(MgOWNERCONDP(mg));
4831     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4832                           (unsigned long)thr, (unsigned long)svv);)
4833     MUTEX_UNLOCK(MgMUTEXP(mg));
4834 }
4835 #endif /* USE_THREADS */
4836
4837 PP(pp_lock)
4838 {
4839     djSP;
4840     dTOPss;
4841     SV *retsv = sv;
4842 #ifdef USE_THREADS
4843     MAGIC *mg;
4844
4845     if (SvROK(sv))
4846         sv = SvRV(sv);
4847
4848     mg = condpair_magic(sv);
4849     MUTEX_LOCK(MgMUTEXP(mg));
4850     if (MgOWNER(mg) == thr)
4851         MUTEX_UNLOCK(MgMUTEXP(mg));
4852     else {
4853         while (MgOWNER(mg))
4854             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4855         MgOWNER(mg) = thr;
4856         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4857                               (unsigned long)thr, (unsigned long)sv);)
4858         MUTEX_UNLOCK(MgMUTEXP(mg));
4859         save_destructor(unlock_condpair, sv);
4860     }
4861 #endif /* USE_THREADS */
4862     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4863         || SvTYPE(retsv) == SVt_PVCV) {
4864         retsv = refto(retsv);
4865     }
4866     SETs(retsv);
4867     RETURN;
4868 }
4869
4870 PP(pp_threadsv)
4871 {
4872     djSP;
4873 #ifdef USE_THREADS
4874     EXTEND(SP, 1);
4875     if (PL_op->op_private & OPpLVAL_INTRO)
4876         PUSHs(*save_threadsv(PL_op->op_targ));
4877     else
4878         PUSHs(THREADSV(PL_op->op_targ));
4879     RETURN;
4880 #else
4881     DIE("tried to access per-thread data in non-threaded perl");
4882 #endif /* USE_THREADS */
4883 }